Copyright>        OpenRadioss
Copyright>        Copyright (C) 1986-2023 Altair Engineering Inc.
Copyright>
Copyright>        This program is free software: you can redistribute it and/or modify
Copyright>        it under the terms of the GNU Affero General Public License as published by
Copyright>        the Free Software Foundation, either version 3 of the License, or
Copyright>        (at your option) any later version.
Copyright>
Copyright>        This program is distributed in the hope that it will be useful,
Copyright>        but WITHOUT ANY WARRANTY; without even the implied warranty of
Copyright>        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Copyright>        GNU Affero General Public License for more details.
Copyright>
Copyright>        You should have received a copy of the GNU Affero General Public License
Copyright>        along with this program.  If not, see <https://www.gnu.org/licenses/>.
Copyright>
Copyright>
Copyright>        Commercial Alternative: Altair Radioss Software
Copyright>
Copyright>        As an alternative to this open-source version, Altair also offers Altair Radioss
Copyright>        software under a commercial license.  Contact Altair to discuss further if the
Copyright>        commercial version may interest you: https://www.altair.com/radioss/.
#if defined(MUMPS5) 
Chd|====================================================================
Chd|  IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        RESOL                         source/engine/resol.F         
Chd|-- calls ---------------
Chd|        ARRET                         source/system/arret.F         
Chd|        BFGS_INI                      source/implicit/imp_bfgs.F    
Chd|        CFIELD_IMP                    source/loads/general/load_centri/cfield_imp.F
Chd|        CONDENS_B                     source/implicit/upd_glob_k.F  
Chd|        CP_IMPBUF                     source/implicit/produt_v.F    
Chd|        CP_INT_HP                     source/implicit/produt_v.F    
Chd|        CP_REAL_HP                    source/implicit/produt_v.F    
Chd|        CRIT_LLIM                     source/implicit/imp_solv.F    
Chd|        DEALLOCM                      source/implicit/imp_solv.F    
Chd|        DIM_INT_K                     source/implicit/ind_glob_k.F  
Chd|        DIS_CP                        source/implicit/imp_solv.F    
Chd|        DU_INI_HP                     source/implicit/imp_solv.F    
Chd|        DYNA_CPK0                     source/implicit/imp_dyna.F    
Chd|        DYNA_CPR0                     source/implicit/imp_dyna.F    
Chd|        DYNA_INA                      source/implicit/imp_dyna.F    
Chd|        DYNA_WEX                      source/implicit/imp_dyna.F    
Chd|        ETFAC_INI                     source/implicit/imp_init.F    
Chd|        FIL_SPAN1                     source/implicit/ind_glob_k.F  
Chd|        FORCE                         source/loads/general/force.F  
Chd|        FVBC_IMPL1                    source/constraints/general/impvel/fv_imp0.F
Chd|        FV_DD0                        source/constraints/general/impvel/fv_imp0.F
Chd|        FV_FINT0                      source/constraints/general/impvel/fv_imp0.F
Chd|        FV_IMP                        source/constraints/general/impvel/fv_imp0.F
Chd|        FV_IMP1                       source/constraints/general/impvel/fv_imp0.F
Chd|        FV_RW                         source/constraints/general/impvel/fv_imp0.F
Chd|        GETNDDLI_G                    source/mpi/implicit/imp_fri.F 
Chd|        GET_FEXT                      source/implicit/imp_solv.F    
Chd|        GET_NSPC                      source/constraints/general/bcs/bc_imp0.F
Chd|        GRAVIT_IMP                    source/loads/general/grav/gravit_imp.F
Chd|        IDDL2NOD                      source/implicit/recudis.F     
Chd|        IDEL_INT                      source/implicit/ind_glob_k.F  
Chd|        IMP_B2A                       source/implicit/imp_solv.F    
Chd|        IMP_CHECK                     source/implicit/imp_solv.F    
Chd|        IMP_CHECM                     source/implicit/imp_solv.F    
Chd|        IMP_DTKIN                     source/implicit/imp_int_k.F   
Chd|        IMP_DTN                       source/implicit/imp_dt.F      
Chd|        IMP_DYKV                      source/implicit/imp_dyna.F    
Chd|        IMP_DYKV0                     source/implicit/imp_dyna.F    
Chd|        IMP_DYNAM                     source/implicit/imp_dyna.F    
Chd|        IMP_FR7I                      source/mpi/implicit/imp_fri.F 
Chd|        IMP_GLOB_KHP                  source/implicit/imp_glob_k.F  
Chd|        IMP_INTFR                     source/implicit/imp_solv.F    
Chd|        IMP_INTTD0                    source/implicit/imp_int_k.F   
Chd|        IMP_INT_K                     source/implicit/imp_int_k.F   
Chd|        IMP_KPRES                     source/implicit/imp_glob_k.F  
Chd|        IMP_MUMPS1                    source/implicit/imp_mumps.F   
Chd|        IMP_QIFAM                     source/implicit/imp_dyna.F    
Chd|        IMP_SETB                      source/implicit/imp_setb.F    
Chd|        IMP_STOP                      source/implicit/imp_solv.F    
Chd|        IND_FRKD                      source/mpi/implicit/imp_fri.F 
Chd|        IND_GLOB_K                    source/implicit/ind_glob_k.F  
Chd|        IND_INT_K                     source/implicit/ind_glob_k.F  
Chd|        INI_BMINMA_IMP                source/implicit/imp_solv.F    
Chd|        INI_K0H                       source/implicit/imp_solv.F    
Chd|        INI_KIC                       source/implicit/imp_solv.F    
Chd|        INI_KIF                       source/implicit/imp_solv.F    
Chd|        INT5_DIVERG                   source/implicit/imp_solv.F    
Chd|        INTEGRATOR1_HP                source/implicit/integrator.F  
Chd|        INTEGRATORL_HP                source/implicit/integrator.F  
Chd|        INTEGRATOR_HP                 source/implicit/integrator.F  
Chd|        KIN_KNL                       source/implicit/imp_int_k.F   
Chd|        K_BAND                        source/implicit/imp_solv.F    
Chd|        LIN_SOLV                      source/implicit/lin_solv.F    
Chd|        MONV_IMP                      source/airbag/monv_imp0.F     
Chd|        MY_BARRIER                    source/system/machine.F       
Chd|        M_LNZ                         source/implicit/imp_solv.F    
Chd|        NL_SOLV                       source/implicit/nl_solv.F     
Chd|        PRODUT_HP                     source/implicit/produt_v.F    
Chd|        PRODUT_UHP0                   source/implicit/produt_v.F    
Chd|        PR_INFOK                      source/implicit/imp_solv.F    
Chd|        PR_SOLNFO                     source/implicit/imp_solv.F    
Chd|        PUT_NSPC                      source/constraints/general/bcs/bc_imp0.F
Chd|        QSTAT_INI                     source/implicit/imp_dyna.F    
Chd|        RECUKIN                       source/implicit/recudis.F     
Chd|        RER02                         source/implicit/upd_glob_k.F  
Chd|        RGWAL0_IMP                    source/constraints/general/rwall/rgwal0.F
Chd|        SAVE_KIF                      source/implicit/imp_solv.F    
Chd|        SAV_INTTD                     source/implicit/imp_int_k.F   
Chd|        SPBRM_PRE                     source/implicit/imp_solv.F    
Chd|        SPB_RM_RIG                    source/implicit/imp_solv.F    
Chd|        SPMD_MAX_I                    source/mpi/implicit/imp_spmd.F
Chd|        SPMD_MIN_I                    source/mpi/implicit/imp_spmd.F
Chd|        SPMD_MIN_S                    source/mpi/implicit/imp_spmd.F
Chd|        SPMD_SUMF_A                   source/mpi/implicit/imp_spmd.F
Chd|        STARTIME                      source/system/timer.F         
Chd|        STOPTIME                      source/system/timer.F         
Chd|        UPD_FR_K                      source/mpi/implicit/imp_fri.F 
Chd|        UPD_GLOB_K                    source/implicit/upd_glob_k.F  
Chd|        UPD_RHS                       source/implicit/upd_glob_k.F  
Chd|        VAXPY_HP                      source/implicit/produt_v.F    
Chd|        VSCALY_HP                     source/implicit/produt_v.F    
Chd|        WEIGHTDDL                     source/implicit/recudis.F     
Chd|        ZERO1                         source/system/zero.F          
Chd|        ZEROR_HP                      source/implicit/produt_v.F    
Chd|        DRAPE_MOD                     share/modules/drape_mod.F     
Chd|        DSGRAPH_MOD                   share/modules/dsgraph_mod.F   
Chd|        ELBUFDEF_MOD                  ../common_source/modules/mat_elem/elbufdef_mod.F
Chd|        GROUPDEF_MOD                  ../common_source/modules/groupdef_mod.F
Chd|        H3D_MOD                       share/modules/h3d_mod.F       
Chd|        IMPBUFDEF_MOD                 share/modules/impbufdef_mod.F 
Chd|        IMP_LINTF                     share/modules/impbufdef_mod.F 
Chd|        IMP_PCG_PROJ                  share/modules/impbufdef_mod.F 
Chd|        IMP_WORKI                     share/modules/impbufdef_mod.F 
Chd|        INTBUFDEF_MOD                 ../common_source/modules/intbufdef_mod.F
Chd|        INTERFACES_MOD                ../common_source/modules/interfaces/interfaces_mod.F
Chd|        MESSAGE_MOD                   share/message_module/message_mod.F
Chd|        MULTI_FVM_MOD                 ../common_source/modules/ale/multi_fvm_mod.F
Chd|        SENSOR_MOD                    share/modules/sensor_mod.F    
Chd|        STACK_MOD                     share/modules/stack_mod.F     
Chd|        TH_SURF_MOD                   ../common_source/modules/interfaces/th_surf_mod.F
Chd|====================================================================
      SUBROUTINE IMP_SOLV( 
     1  ICODE  ,ISKEW  ,ISKWN  ,IPART  ,IXTG   ,IXS    ,IXQ    ,
     2  IXC    ,IXT    ,IXP    ,IXR    ,IXTG1          ,ITAB   ,ITABM1 ,
     3  NPC    ,IBCL   ,IBFV   ,SENSOR_TAB,NNLINK ,LNLINK ,IPARG  ,IGRV   ,
     4  IPARI  ,INTBUF_TAB,NPRW   ,ICONX  ,NPBY   ,LPBY   ,LRIVET ,
     5  NSTRF  ,LJOINT ,ICODT  ,ICODR  ,ISKY   ,ADSKY  ,IADS_F ,
     6  ILINK  ,LLINK  ,WEIGHT         ,ITASK  ,IBVEL  ,LBVEL  ,FBVEL  ,
     7  X      ,D      ,V      ,VR     ,DR     ,THKE   ,DAMP   ,MS     ,
     8  IN     ,PM     ,SKEW   ,GEO    ,EANI   ,BUFMAT ,BUFGEO ,BUFSF  ,
     9  TF     ,FORC   ,VEL    ,FSAV   ,AGRV   ,FR_WAVE,PARTS0 ,
     A  ELBUF  ,RBY    ,RIVET  ,FR_ELEM,IAD_ELEM,
     B  WA             ,A      ,AR     ,STIFN  ,STIFR  ,PARTSAV,FSKY   ,
     C  FSKYI  ,IFRAME ,XFRAME ,W16    ,IACTIV ,FSKYM  ,IGEO   ,IPM    ,
     D  TFEXT  ,NODFT  ,NODLT  ,NINT7  ,NUM_IMP,NS_IMP ,NE_IMP ,IND_IMP,
     L  IT     ,RWBUF  ,LPRW   ,FR_WALL,NBINTC ,INTLIST,FOPT   ,RWSAV  ,
     M          FSAVD  ,GRAPHE ,FAC_K  ,IPIV_K ,NKCOND ,NSENSOR,
     N  MONVOL ,IGRSURF,FR_MV  ,VOLMON ,DIRUL  ,
     O  NODGLOB,MUMPS_PAR,CDDLP,ISENDTO,IRECVFROM,NEWFRONT,IMSCH  ,
     P  I2MSCH ,ISIZXV,ILENXV ,ISLEN7  ,IRLEN7 ,ISLEN11,IRLEN11,ISLEN17,
     Q  IRLEN17,IRLEN7T,ISLEN7T,KINET  ,NUM_IMP1,TEMP   ,DT2PREV,WAINT ,
     R  LGRAV   ,SH4TREE ,SH3TREE,IRLEN20,ISLEN20,IRLEN20T,ISLEN20T    ,
     S  IRLEN20E,ISLEN20E,IRBE3,LRBE3  ,FRBE3  ,FR_I2M,IAD_I2M,FR_RBE3M,
     T  IAD_RBE3M,FRWL6,IRBE2 ,LRBE2   ,INTBUF_TAB_C,IKINE  ,DIAG_SMS,
     V  ICFIELD,LCFIELD,CFIELD,COUNT_REMSLV,COUNT_REMSLVE,
     X  ELBUF_TAB,ELBUF_IMP,XDP,WEIGHT_MD , STACK ,
     Y  DIMFB  ,FBSAV6 ,STABSEN,TABSENSOR,DRAPE_SH4N, DRAPE_SH3N,
     Z  H3D_DATA,MULTI_FVM,IGRBRIC,IGRSH4N,IGRSH3N,IGRBEAM,FORNEQS,MAXDGAP,
     A  NDDL0   ,NNZK0 ,IT_T    ,IMPBUF_TAB,CPTREAC,FTHREAC,NODREAC, DRAPEG,
     B  INTERFACES,TH_SURF ,FSAVSURF,NSEG_LOADP) 
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE DSGRAPH_MOD
      USE IMP_LINTF
      USE IMP_WORKI
      USE IMP_PCG_PROJ
      USE MESSAGE_MOD
      USE ELBUFDEF_MOD  
      USE INTBUFDEF_MOD
      USE STACK_MOD
      USE H3D_MOD
      USE MULTI_FVM_MOD
      USE GROUPDEF_MOD
      USE DRAPE_MOD
      USE IMPBUFDEF_MOD
      USE SENSOR_MOD
      USE INTERFACES_MOD
      USE TH_SURF_MOD , ONLY : TH_SURF_
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "comlock.inc"
#include      "dmumps_struc.h"
#include      "param_c.inc"
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "com08_c.inc"
#include      "impl1_c.inc"
#include      "impl2_c.inc"
#include      "scr03_c.inc"
#include      "scr05_c.inc"
#include      "scr06_c.inc"
#include      "scr16_c.inc"
#include      "timeri_c.inc"
#include      "units_c.inc"
#include      "task_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER ,INTENT(IN) :: NSENSOR
      INTEGER ITASK,ICODE(*), ISKEW(*), ISKWN(LISKN,*),ITABM1(*),
     .   IPART(*),IXS(*),IXQ(NIXQ,*),IXC(NIXC,*), IXT(NIXT,*),
     .   IXP(NIXP,*),IXR(NIXR,*), IXTG(NIXTG,*), IXTG1(4,*),
     .   ITAB(*),NPC(*), IBCL(*), IBFV(*),IPARG(NPARG,*),IPARI(NPARI,*),
     .   NPRW(*), NPBY(NNPBY,*), LPBY(*),IADS_F(*),
     .   LRIVET(*), NSTRF(*), LJOINT(*), ICODT(*), ICODR(*), ILINK(*),
     .   LLINK(*),ISKY(*),ADSKY(*),
     .   NNLINK(10,*),LNLINK(*),IGRV(*),IKINE(*),
     .   WEIGHT(*),IFRAME(LISKN,*),IBVEL(NBVELP,*),LBVEL(*),
     .   IACTIV(*),IGEO(*),IPM(*),ICONX(*),NODFT  ,NODLT,IT,
     .   WEIGHT_MD(*),DIMFB,STABSEN,TABSENSOR(*),CPTREAC,NODREAC(*)
      INTEGER LPRW(*), FR_WALL(NSPMD+2,*),FR_ELEM(*),
     .   IAD_ELEM(2,*),NBINTC ,INTLIST(*), IPIV_K(*), NKCOND,
     .   NODGLOB(*), CDDLP(*),LGRAV(*)
      INTEGER NDDL0,NNZK0,IT_T,MONVOL(*),FR_MV(*),
     .        DIRUL(*),SH4TREE(*), SH3TREE(*),
     .        FR_I2M(*),IAD_I2M(*),FR_RBE3M(*),IAD_RBE3M(*),
     .        ICFIELD(*),LCFIELD(*),COUNT_REMSLV(*),COUNT_REMSLVE(*)
      my_real
     .   X(3,*)    ,D(3,*)      ,V(3,*)   ,VR(3,*),DAMP(*),
     .   MS(*)   ,IN(*)   ,PM(NPROPM,*),SKEW(LSKEW,*),GEO(NPROPG,*),
     .   BUFMAT(*) ,TF(*) ,FORC(*)  ,VEL(*),FSAV(NTHVKI,*) ,ELBUF(*) ,
     .   RWBUF(NRWLP,*),RWSAV(*),RBY(NRBY,*),
     .   RIVET(*),WA(*), A(3,*) ,AR(3,*),PARTSAV(*) ,TFEXT,
     .   STIFN(*) ,STIFR(*),FSKY(*),FSKYI(*),DR(3,*),
     .   EANI(*),AGRV(*), THKE(*),FR_WAVE(*),PARTS0(*),BUFGEO(*),
     .   XFRAME(NXFRAME,*),W16(*),FBVEL(*),FSKYM(*),BUFSF(*),
     .   FOPT(6,*),FSAVD(NTHVKI,*), FAC_K(*), DIAG_SMS(*),
     .   CFIELD(*),FORNEQS(*),MAXDGAP(NINTER),FTHREAC(6,*)
      INTEGER  NUM_IMP(*),NS_IMP(*),NE_IMP(*),IND_IMP(*),NINT7
      INTEGER NEWFRONT(*),ISENDTO(*),IRECVFROM(*),IMSCH  ,
     .        I2MSCH ,ISIZXV,ILENXV ,ISLEN7  ,IRLEN7 ,ISLEN11,IRLEN11,
     .        ISLEN17,IRLEN17,IRLEN7T,ISLEN7T,
     .        IRLEN20,ISLEN20,IRLEN20T,ISLEN20T,IRLEN20E,ISLEN20E,
     .        KINET(*),NUM_IMP1(*),IRBE3(*),LRBE3(*),IRBE2(*),LRBE2(*)
C     REAL
      my_real
     .  DT2PREV,VOLMON(*) ,TEMP(*),
     .  WAINT(*),FRBE3(*)
      TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB, ELBUF_IMP
      DOUBLE PRECISION
     .        FRWL6(*), XDP(3,*)
      DOUBLE PRECISION
     .        FBSAV6(12,6,DIMFB)
C
      TYPE(PRGRAPH) :: GRAPHE(*)
C
      TYPE(DMUMPS_STRUC) MUMPS_PAR
      TYPE(INTBUF_STRUCT_) INTBUF_TAB(*), INTBUF_TAB_C
      TYPE (STACK_PLY) :: STACK
      TYPE(H3D_DATABASE) :: H3D_DATA
      TYPE(MULTI_FVM_STRUCT), INTENT(INOUT) :: MULTI_FVM
!
      TYPE (GROUP_)  , DIMENSION(NGRBRIC) :: IGRBRIC
      TYPE (GROUP_)  , DIMENSION(NGRSHEL) :: IGRSH4N
      TYPE (GROUP_)  , DIMENSION(NGRSH3N) :: IGRSH3N
      TYPE (GROUP_)  , DIMENSION(NGRBEAM) :: IGRBEAM
      TYPE (GROUP_)  , DIMENSION(NSURF)   :: IGRSURF
      TYPE (DRAPE_)   :: DRAPE_SH4N(NUMELC_DRAPE), DRAPE_SH3N(NUMELTG_DRAPE)
      TYPE (IMPBUF_STRUCT_) ,TARGET :: IMPBUF_TAB
      TYPE (SENSOR_STR_) ,DIMENSION(NSENSOR) :: SENSOR_TAB
      TYPE (DRAPEG_)   :: DRAPEG
      TYPE (INTERFACES_)    ,INTENT(IN)     :: INTERFACES
      TYPE (TH_SURF_) , INTENT(IN) :: TH_SURF
      my_real, INTENT(INOUT) :: FSAVSURF(5,NSURF)
      INTEGER, INTENT(INOUT) :: NSEG_LOADP(NSURF)
C      
C---D_IMP: dUn+1,i,DD : ddU,i+1
C---R_IMP[1:R02,2:RRR(R_OLD),3:RU0,4:E02,5:DE_OLD,6:EIMP,7,8,9:pour line-search]
C---R_IMP[10: BFAC,DTFAC,11:U2,12:RFAC,13:|FEXT|;14,16:new line-search;17:actual R02;18:GAP;19:TSTART;
C---R_IMP[21:rel res disp.,22:rel res force,23:rel res energy,24:cumul arc length]
C---------20-25:libre
C---I_IMP[1:IT(TOTAL),2:ITC,3:IT0(IT_OLD),4:IWAIT,5:IDIV,6:NDDLI0,7:1ercontact(used only w/ IREFI=4),
C---8:num. of diverging, 9:ICONT_OLD 10:Isign (Riks);11: Ichang(solver);12: IDIV_OLD;13: NDDLI(SMP) or NDDLI_G(SPMD)
C----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER  NNMAX,NKMAX,N_IMPN,N_IMPM,LNSS,LNSS2,NDT,NDS,NT_RW
      INTEGER I,J,NTMP,L1,L2,L3,NNDL,INPRINT,ISTOP,LI10,LI11,
     .        LI1,LI2,LI3,LI4,LI5,LI6,LI7,LI8,LI9,LIF,IC,ISETP,
     .        LI12,NDDL_INI0,LI13,LI14,LI15,LNSS3,LNSB2,LNSRB2
      INTEGER, DIMENSION(:),ALLOCATABLE :: IADI0,JDII0
C
      INTEGER, DIMENSION(:),ALLOCATABLE :: NSS,ISS,NSS2,ISS2,NSS3,ISS3
      INTEGER, DIMENSION(:),ALLOCATABLE :: NSB2,ISB2,IAINT2
C      ---INEGA is defined now in impl1_c.inc---
      INTEGER  NNOD,IFDIS,NODFTSK ,NODLTSK,N1,N2,N3
C
      INTEGER LBAND,NCL_MAX,IRFLAG,IPRINT0,IPRJ_S
C
      INTEGER IBID,IFIF,F_DDL,L_DDL,NSPC_OLD,NSPC,NFXV_G
C
      my_real
     .        RBID,EFAC,LBB(NDDL0)
      my_real
     .  TFEXC,TMP,TMP1,TMP2,R2,BFAC,FACI,R02,GAP,BID,WE_IMP
      my_real,
     .         DIMENSION(:),ALLOCATABLE :: DIAG_I0,LT_I0
C	 
      INTEGER, POINTER     :: NDDL,NNZK,NRBYAC,NINT2,NMC,NMC2,NMONV
      INTEGER, DIMENSION(:) ,POINTER     :: IADK,JDIK,IADM,JDIM
      INTEGER, DIMENSION(:) ,POINTER     :: IDDL,NDOF,INLOC,LSIZE,I_IMP,IKC,
     .                                      IRBYAC,NSC,IINT2,NKUD,IMONV,
     .                                      IKINW,W_DDL,IKUDN,NDOFI,IDDLI,IKUD
      my_real, DIMENSION(:) ,POINTER     :: DIAG_K,LT_K,DIAG_M,LT_M,LB,
     .                                      LB0,BKUD,D_IMP,ELBUF_C,BUFMAT_C,
     .                                      DR_IMP,X_C,DD,DDR,X_A,R_IMP
      my_real, DIMENSION(:) ,POINTER     :: FEXT,DG,DGR,DG0,DGR0,BUFIN_C,AC,ACR
c sb
      character*1 anew_stif
	  
C-----------------------------------------------
      anew_stif = ' '
c
C-----------------------------------------------
C---IMCONV : 0 iteration; 1 converge; -1 line-search, -2 change dt during iteration-----
C---         -3 only reset iteration with Dn-1=0-----
C-----------------------------------------------
          NDDL => IMPBUF_TAB%NDDL
          NNZK => IMPBUF_TAB%NNZK
          NRBYAC => IMPBUF_TAB%NRBYAC
          NINT2 => IMPBUF_TAB%NINT2
          NMC => IMPBUF_TAB%NMC
          NMC2 => IMPBUF_TAB%NMC2
          NMONV => IMPBUF_TAB%NMONV
          IADK => IMPBUF_TAB%IADK
          JDIK => IMPBUF_TAB%JDIK
          IADM => IMPBUF_TAB%IADM
          JDIM => IMPBUF_TAB%JDIM
          IDDL => IMPBUF_TAB%IDDL
          NDOF => IMPBUF_TAB%NDOF
          INLOC => IMPBUF_TAB%INLOC
          LSIZE => IMPBUF_TAB%LSIZE
          I_IMP => IMPBUF_TAB%I_IMP
          IRBYAC => IMPBUF_TAB%IRBYAC
          NSC => IMPBUF_TAB%NSC
          IINT2 => IMPBUF_TAB%IINT2
          NKUD => IMPBUF_TAB%NKUD
          IMONV => IMPBUF_TAB%IMONV
          IKINW => IMPBUF_TAB%IKINW
          IKC => IMPBUF_TAB%IKC
          W_DDL => IMPBUF_TAB%W_DDL
          IKUD => IMPBUF_TAB%IKUD
          NDOFI=> IMPBUF_TAB%NDOFI
          IDDLI=> IMPBUF_TAB%IDDLI
C		  
          DIAG_K  =>IMPBUF_TAB%DIAG_K  
		  LT_K    =>IMPBUF_TAB%LT_K    
		  DIAG_M  =>IMPBUF_TAB%DIAG_M  
		  LT_M    =>IMPBUF_TAB%LT_M    
		  LB      =>IMPBUF_TAB%LB      
          LB0     =>IMPBUF_TAB%LB0      
		  BKUD    =>IMPBUF_TAB%BKUD    
		  D_IMP   =>IMPBUF_TAB%D_IMP   
		  DR_IMP  =>IMPBUF_TAB%DR_IMP   
		  ELBUF_C =>IMPBUF_TAB%ELBUF_C 
		  BUFMAT_C=>IMPBUF_TAB%BUFMAT_C
	      X_C     =>IMPBUF_TAB%X_C     
	      X_A     =>IMPBUF_TAB%X_A     
		  DD      =>IMPBUF_TAB%DD      
		  DDR     =>IMPBUF_TAB%DDR     
		  FEXT  =>IMPBUF_TAB%FEXT  
		  DG    =>IMPBUF_TAB%DG    
		  DGR   =>IMPBUF_TAB%DGR   
		  DG0   =>IMPBUF_TAB%DG0    
		  DGR0  =>IMPBUF_TAB%DGR0   
c		  BUFIN_C=>IMPBUF_TAB%BUFIN_C
		  AC=>IMPBUF_TAB%AC
		  ACR=>IMPBUF_TAB%ACR
          R_IMP => IMPBUF_TAB%R_IMP
		  ALLOCATE(IAINT2(NINT2))
C--------explicite iteration only-------------
C-------smp // first for IMP_GLOB_K, PCG solver, Nonlinear drivers,
         NDT=NEXP
         IF (I_IMP(4)>0) THEN
          CALL INTEGRATOR_HP(NDT  ,D_IMP ,DR_IMP,
     1                       X     ,V     ,VR    ,A     ,AR    )
C    /---------------/
           I_IMP(4)=I_IMP(4)-1
           IF (IMCONV==1) IMCONV=2
          RETURN
         ENDIF
C------------------------------
C        Initialisation
C------------------------------
         IPRINT0=0
         IF (ISPMD==0) THEN
          IF(NCYCLE==1.AND.IMCONV==1.AND.I_IMP(5)==0) IPRINT0=1
          IF (ILINE/=1) INPRINT=NPRINT
         ELSE
          INPRINT=0
         ENDIF
C
         IF (IRREF>0.AND.IMCONV==1.AND.ILINE/=1) THEN
          IRFLAG=IRREF
         ELSE
          IRFLAG=0
         ENDIF
C
         ISETP=ISETK
         NDDLI=0
         NDDLI_G=0
         IF (NINT7==0) THEN
          DO I=1,NUMNOD
           NDOFI(I)=0
          ENDDO
         ENDIF
         ISTOP=0
         IF (IMCONV==2) IMCONV=1
         NNDL = 3*NUMNOD
C
         NSREM=0
         NSL=0
         ICONTA = 0
C
         WE_IMP = TFEXT
         IF (IMCONV==1) THEN
          ITER_NL=0
         ELSE
          ITER_NL=IT+1
         END IF
         IF(NCYCLE==1.AND.IMCONV==1.AND.I_IMP(5)==0) THEN
          R_IMP(19)=TT-DT2
C---------for interface sorting         
          IF(NINTER>0) CALL INI_BMINMA_IMP
         END IF
c
C-----------------------------
Citask0        IF (ITASK == 0) THEN
C-----------------------------
         IF (IMCONV==3) CALL CP_REAL_HP(NNDL,X_C,X)
         NFXV_G = NFXVEL
         IF (NSPMD>1) CALL SPMD_MAX_I(NFXV_G)
C
         IF (ILINTF>0) THEN
           ALLOCATE(XI_C(NNDL))
           IF (NCYCLE==1) THEN
            CALL CP_IMPBUF(
     .           1      ,ELBUF,ELBUF_C,BUFMAT ,BUFMAT_C,
     .                     FSAV  ,VOLMON  ,PARTSAV ,INTBUF_TAB       ,
     .                     INTBUF_TAB_C,IPARI   ,ISLEN7 ,IRLEN7   ,
     .                     ISLEN11,IRLEN11,ISLEN17 ,IRLEN17,IRLEN7T  ,
     .                     ISLEN7T,IRLEN20,ISLEN20 ,IRLEN20T,ISLEN20T,
     .           IRLEN20E,ISLEN20E,NEWFRONT,ELBUF_TAB,ELBUF_IMP,
     .           IPARG   )
            CALL CP_REAL_HP(NNDL,X,X_C)
            CALL IMP_SETB(A ,AR ,IDDL ,NDOF ,LB0  )
            CALL INI_KIF
            I_IMP(2)=LPRINT
            LPRINT = 0
            CALL CP_REAL_HP(NNDL,X,XI_C)
           ELSE
            CALL CP_IMPBUF(
     .           2     ,ELBUF,ELBUF_C,BUFMAT ,BUFMAT_C,
     .                     FSAV  ,VOLMON  ,PARTSAV ,INTBUF_TAB       ,
     .                     INTBUF_TAB_C,IPARI   ,ISLEN7 ,IRLEN7   ,
     .                     ISLEN11,IRLEN11,ISLEN17 ,IRLEN17,IRLEN7T  ,
     .                     ISLEN7T,IRLEN20,ISLEN20 ,IRLEN20T,ISLEN20T,
     .           IRLEN20E,ISLEN20E,NEWFRONT,ELBUF_TAB,ELBUF_IMP,          
     .           IPARG   )
            CALL CP_REAL_HP(NNDL,X_C,X)
            CALL CP_REAL_HP(NNDL,X_C,XI_C)
            CALL INTEGRATOR1_HP(D_IMP ,XI_C )
            CALL IMP_B2A(A ,AR ,IDDL ,NDOF ,LB0  )
            IF (NCYCLE==ILINTF) THEN
             LPRINT = I_IMP(2)
            ELSE
             LPRINT = 0
            ENDIF
C----------otherwise, X_A is accumulated---            
            CALL CP_REAL_HP(NNDL,X,X_A)
           ENDIF
         ENDIF
C
         IF (IMCONV==1 ) THEN
           R_IMP(16)=ZERO
C          R_IMP(6)=ZERO
C---------initialise D,DD-----
             IF (NCYCLE>1.AND.ILINE/=1) THEN
C-----------------Dn,0=Dn-1--------
c              CALL CP_REAL(NNDL,D_IMP,DD)
c              IF (IRODDL/=0) CALL CP_REAL(NNDL,DR_IMP,DDR)
C----------for the case where the run diverges due to the first contact(Gravity)->
C----------use reduced Dn_1 instead of resolution: 
               CALL DU_INI_HP(D_IMP  ,DR_IMP,DD    ,
     1                        DDR   ,I_IMP(5),I_IMP(7))
             ENDIF
             CALL ZEROR_HP(D_IMP,NUMNOD)
             IF (IRODDL/=0) CALL ZEROR_HP(DR_IMP,NUMNOD)
C         permet aussi de faire linear avec 'initial state'
            CALL ZEROR_HP(AC,NUMNOD)
            IF (IRODDL/=0) CALL ZEROR_HP(ACR,NUMNOD)
C
           IF (ISIGINI==1.AND.NCYCLE==1) THEN
            CALL IMP_SETB(A ,AR ,IDDL ,NDOF ,LB0  )
           ENDIF
C
         IF (NCYCLE==1.AND.IDYNA>0)
     .      CALL DYNA_INA(IBCL  ,FORC   ,NPC   ,TF    ,A     ,
     2                    V     ,X      ,SKEW  ,AR    ,VR    ,
     3                    SENSOR_TAB,WEIGHT,TFEXC ,IADS_F ,
     4                    FSKY  ,IGRV   ,AGRV  ,MS    ,IN    ,
     5                    LGRAV ,ITASK ,NRBYAC,IRBYAC ,NPBY  ,
     6                    RBY   ,FR_ELEM,IAD_ELEM,NDDL0,NNZK0,
     7                    I_IMP(5),H3D_DATA,CPTREAC,FTHREAC,NODREAC,
     8                    NSENSOR,TH_SURF ,FSAVSURF, NSEG_LOADP)
C
C----------------------------------
C       FORCES EXTERNES A=Fext-Fint
C----------------------------------
C
         NCL_MAX=0
         IF(NCONLD/=0) THEN
          IF (IMON>0) CALL STARTIME(4,1)
C         --en spmd force est traite comme elements---
          CALL FORCE(IBCL   ,FORC    ,NPC    ,TF    ,AC     ,
     2               V      ,X       ,SKEW   ,ACR   ,VR     ,
     3               NSENSOR,SENSOR_TAB,TFEXC,
     4               IADS_F ,FSKY    ,FSKY   ,RBID,H3D_DATA,
     5               CPTREAC ,FTHREAC,NODREAC ,TH_SURF ,FSAVSURF,
     6               NSEG_LOADP)
C
         IF (IMACH==3.AND.NSPMD>1) THEN
          DO I=IAD_ELEM(1,1),IAD_ELEM(1,NSPMD+1)-1
            J = FR_ELEM(I)
	        N1 = 3*(J-1)+1
	        N2 = 3*(J-1)+2
	        N3 = 3*(J-1)+3
            TMP = ABS(AC(N1))+ABS(AC(N2))+ABS(AC(N3))
            IF (IRODDL/=0) TMP = TMP +
     .            ABS(ACR(N1))+ABS(ACR(N2))+ABS(ACR(N3))
            IF (TMP>ZERO) NCL_MAX = NCL_MAX + 1
          ENDDO
          ENDIF
C
           IF (IMON>0) CALL STOPTIME(4,1)
         ENDIF
C
        IF (IMACH==3.AND.NSPMD>1) THEN
         CALL SPMD_MAX_I(NCL_MAX)
         IF (NCL_MAX>0) THEN
          LBAND = IAD_ELEM(1,NSPMD+1)-IAD_ELEM(1,1)
          IF (IRODDL/=0) THEN
           NTMP = 6
          ELSE
           NTMP = 3
          ENDIF
          CALL SPMD_SUMF_A(AC,ACR,IAD_ELEM,FR_ELEM,NTMP,LBAND)
         ENDIF
        ENDIF
C---------no //SMP for the moment, add it after----
         IF(NGRAV/=0) THEN
          IF (IMON>0) CALL STARTIME(4,1)
          CALL GRAVIT_IMP(IGRV  ,AGRV  ,NPC   ,TF    ,AC,
     2                    V     ,X     ,SKEW  ,MS,TFEXC,
     3                    NSENSOR,SENSOR_TAB,WEIGHT,
     4                    LGRAV ,ITASK,
     5                    NRBYAC,IRBYAC,NPBY  ,RBY    )
          IF (IMON>0) CALL STOPTIME(4,1)
         ENDIF
C---------no //SMP for the moment, add it after----
         IF(NLOADC/=0) THEN
          IF (IMON>0) CALL STARTIME(4,1)
          CALL CFIELD_IMP(ICFIELD  ,CFIELD,NPC   ,TF    ,AC,
     2                    V     ,X     ,XFRAME  ,MS,TFEXC,
     3                    NSENSOR,SENSOR_TAB,WEIGHT,IFRAME,
     4                    LCFIELD ,ITASK,
     5                    NRBYAC,IRBYAC,NPBY  ,RBY,ISKEW    )
          IF (IMON>0) CALL STOPTIME(4,1)
         ENDIF


          TFEXT = WE_IMP
C fin IF (IMCONV==1)
         ENDIF
C-------------dU_d---------------------------------
        IF(NFXVEL/=0.AND.(IMCONV==1.OR.IMCONV==3)) THEN
          IF (IMON>0) CALL STARTIME(4,1)
          CALL FV_IMP(IBFV  ,NPC    ,TF     ,VEL   ,SENSOR_TAB,
     1                D_IMP  ,DR_IMP ,IKC   ,IDDL  ,NSENSOR   ,
     2                SKEW  ,IFRAME ,XFRAME ,V     ,VR    ,
     3                X     ,DIRUL  ,NDOF   ,A     ,AR    )
          IF (IMON>0) CALL STOPTIME(4,1)
        ENDIF
C-------------RGWAL0_IMP peut suivre-ISETK=1, mais il faut changer-FV_IMP1
C-------------(IKC(I)=4->IMCONV=1 pour eviter le rebond-------
        NT_RW=0
        NRWDONE = 0
        IF (NRWALL>0) THEN
         IF (IMON>0) CALL STARTIME(4,1)
         DO I=1,NDDL0
          IF (IKC(I)==3.OR.IKC(I)==10) IKC(I)=0
         ENDDO
         IF (IMCONV==1) THEN
          DO I=1,NDDL0
           IF (IKC(I)==4.OR.IKC(I)==11) IKC(I)=0
          ENDDO
         ENDIF

         IF (ISMDISP>0.AND.ILINE==0) THEN
          CALL RGWAL0_IMP(
     1     X_A         ,D_IMP    ,V      ,RWBUF   ,LPRW    ,
     2     NPRW        ,MS       ,FSAV(1,NINTER+1),FR_WALL ,
     3     FOPT        ,RWSAV    ,WEIGHT ,FSAVD(1,NINTER+1),
     4     NT_RW       ,IDDL     ,IKC    ,IMCONV,NDOF,FRWL6,
     5     WEIGHT_MD   ,DIMFB    , FBSAV6,STABSEN,TABSENSOR)
         ELSE
          CALL RGWAL0_IMP(
     1     X           ,D_IMP    ,V      ,RWBUF   ,LPRW    ,
     2     NPRW        ,MS       ,FSAV(1,NINTER+1),FR_WALL ,
     3     FOPT        ,RWSAV    ,WEIGHT ,FSAVD(1,NINTER+1),
     4     NT_RW       ,IDDL     ,IKC    ,IMCONV,NDOF,FRWL6,
     5     WEIGHT_MD   ,DIMFB    , FBSAV6,STABSEN,TABSENSOR)     
         ENDIF
C
         IF(NT_RW>0) THEN
          CALL FV_RW(IDDL   ,IKC   ,NDOF  ,D_IMP  ,V )
         ENDIF
         IF (IMON>0) CALL STOPTIME(4,1)
        ENDIF
C
        IFDIS=NT_RW+NFXV_G
        IF(IFDIS>0.AND.IMCONV==1) THEN
          IF (NCYCLE>1.AND.ILINE/=1)
C--------------Dn,0=Dn-1--------
     .    CALL FV_DD0(IDDL   ,IKC   ,NDOF  ,DD  ,DDR ,D_IMP)
          IF(NT_RW>0) THEN
           DO I=1,NDDL0
            IF (IKC(I)==3) IKC(I)=4
C
            IF (IKC(I)==10) IKC(I)=11
           ENDDO
          ENDIF
        ENDIF
C
        IRWALL = NT_RW
        IF (NSPMD>1) CALL SPMD_MAX_I(IRWALL)
C-------!!!should stop line-search if Rwall activates!!!
        IF(IRWALL>0.AND.IMCONV>=0) THEN
          IF(IMACH/=3.OR.ISPMD==0) THEN
           WRITE(IOUT,*)'  *--------- RIGID WALL IMPACT---------*'
           WRITE(ISTDO,*)'  *--------- RIGID WALL IMPACT---------*'
          ENDIF
          ISETK = 1
        ENDIF
C
C----------------------------------
C       LB=Fext ;
C----------------------------------
C---------
         CALL IMP_SETB(AC    ,ACR     ,IDDL   ,NDOF  ,LB    )
C-----------------------
citask0        END IF !(ITASK == 0) THEN
C----------------------
c      CALL MY_BARRIER
C---------------------
C-----------------------
        IF (ISOLV==5.OR.ISOLV==6.AND.IMCONV>=0) THEN
         IF (IDSC==0) THEN
C-----------one update per increment
          IF (IPUPD==0.AND.I_IMP(2)==0.AND.IT==0) THEN
           IDSC=MAX(IDSC,ISETK)
          ENDIF
C-----------NDDL could be changed by RWALL impact
          IF(IRWALL > 0 ) IDSC = 1
         ENDIF
        ELSE
         IDSC=MAX(IDSC,ISETK)
        END IF
C    /---------------/
c      CALL MY_BARRIER
C    /---------------/
C----------------------------------
C       MATRICE DE RIGIDITE
C----------------------------------
        IF (ISETK ==1 ) THEN
          IF (IMON>0 .AND. ITASK ==0) CALL STARTIME(31,1)
          L1 = 1+NIXS*NUMELS
          L2 = L1+6*NUMELS10
          L3 = L2+12*NUMELS20
C----------------------------------
Citask0         IF (ITASK == 0) THEN
C----------------------------------
          NDDL = NDDL0
          NNZK = NNZK0
          NNMAX=LSIZE(9)
          NKMAX=LSIZE(10)
          NMC2=LSIZE(11)
          CALL ZERO1(DIAG_K,NDDL)
          CALL ZERO1(LT_K,NNZK)
          LI1 =1
          LI2 = LI1+LSIZE(4)
          LI3 = LI2+LSIZE(5)
          LI4 = LI3+LSIZE(1)
          LI5 = LI4+LSIZE(3)
          LI6 = LI5+LSIZE(7)
          LI7 = LI6+LSIZE(2)
          LI8 = LI7+LSIZE(6)
          LI9 = LI8+NINT2
          LI10 = LI9+LSIZE(8)
C
          LI11 = LI10+(LSIZE(8)-LCOKM)*LSIZE(9)
          LI12 = LI11+LCOKM*LSIZE(10)
          LI13 = LI12+4*LSIZE(11)
          LI14 = LI13+LSIZE(14)
          LI15 = LI14+LSIZE(15)
          LIF = LI15+LSIZE(16)
C---------attention si rigid body reactive(deactive) pendant un restart il faut relancer aussi dim
          IF (ILINE/=1) THEN
           NTMP=0
               IF (I_IMP(11)==1) THEN
            NTMP=1
                I_IMP(11)=-1
              ENDIF
           CALL IND_GLOB_K(NPBY  ,LPBY      ,
     1    ITAB      ,NRBYAC    ,IRBYAC    ,NSC       ,IKINW(LI1),
     2    NMC       ,IKINW(LI2),IKINW(LI3),IKINW(LI4),NINT2     ,
     3    IINT2     ,IPARI     ,INTBUF_TAB,IKINW(LI8),IKINW(LI5),
     4    IKINW(LI6),IKINW(LI7),IPARG     ,ELBUF     ,ELBUF_TAB ,
     5    IXS       ,IXQ       ,IXC       ,IXT       ,IXP       ,
     6    IXR       ,IXTG      ,IXTG1     ,IXS(L1)   ,IXS(L2)   ,
     7    IXS(L3)   ,IDDL      ,NDOF      ,IADK      ,
     8    JDIK      ,NDDL      ,NNZK      ,NNMAX     ,LSIZE(8)  ,
     9    INLOC     ,NKMAX     ,IKINW(LI9),IKINW(LI10),IKINW(LI11),
     A    NMC2      ,IKINW(LI12),NTMP     ,LSIZE(12) ,LSIZE(13) ,
     B    FR_ELEM   ,IAD_ELEM  ,IPM       ,IGEO      ,IRBE3     ,
     C    LRBE3     ,IKINW(LI13),FR_I2M   ,IAD_I2M   ,FR_RBE3M  ,
     D    IAD_RBE3M ,IRBE2     ,LRBE2     ,IKINW(LI14),IKINW(LI15))
C-------------important is no buffer overflow
C           NDDL0 = NDDL
C           NNZK0 = NNZK
          ENDIF
C----------------------------------
citask0         END IF !IF (ITASK == 0) THEN
C----------------------------------
C    /---------------/
c      CALL MY_BARRIER
C    /---------------/
c          NGDONE = 1
         CALL IMP_GLOB_KHP(
     1    PM        ,GEO       ,IPM       ,IGEO      ,ELBUF     ,
     2    IXS       ,IXQ       ,IXC       ,IXT       ,IXP       ,
     3    IXR       ,IXTG      ,IXTG1     ,IXS(L1)   ,
     4    IXS(L2)   ,IXS(L3)   ,IPARG     ,TF        ,NPC       ,
     5    FR_WAVE   ,W16       ,BUFMAT    ,THKE      ,BUFGEO    ,
     6    RBY       ,SKEW      ,X         ,
     7    WA        ,IDDL      ,NDOF      ,DIAG_K    ,LT_K      ,
     8    IADK      ,JDIK      ,IKG       ,IBID      ,ITASK     ,
     9    ELBUF_TAB ,STACK     ,DRAPE_SH4N, DRAPE_SH3N   ,DRAPEG )
C
C    /---------------/
c      CALL MY_BARRIER
C    /---------------/
       NDDL_L = NDDL
C-----------------------------
citask0       IF (ITASK == 0) THEN
C-----------------------------
        IF (IDYNA>0.AND.IDY_DAMP>0) THEN
         CALL DYNA_CPK0(NDDL  ,NNZK  ,IADK  ,JDIK   ,DIAG_K ,
     .                  LT_K  )
        END IF
C-------estimation of A(t+dt) w/ initial velocity----
        IF (NCYCLE==1.AND.IMCONV==1.AND.I_IMP(5)==0
     .      .AND.IDYNA>0.AND.NINVEL>0) THEN
          CALL IMP_DYKV0(NODFT  ,NODLT   ,IDDL   ,NDOF   ,IKC    ,
     .                   DIAG_K ,IADK    ,JDIK   ,LT_K   ,WEIGHT ,
     1                   RBY    ,X       ,SKEW   ,LPBY   ,NPBY   ,
     2                   NRBYAC ,IRBYAC  ,NINT2  ,IINT2  ,IPARI  ,
     3                   INTBUF_TAB      ,IRBE3  ,LRBE3  ,FRBE3  ,
     4                   IRBE2  ,LRBE2   ,V      ,VR     ,NDDL0  ,
     5                   FR_ELEM,IAD_ELEM,MS     ,IN     )
        END IF
        IF (IDYNA>0.OR.IQSTAT>0)
     .   CALL IMP_DYNAM(NODFT  ,NODLT   ,IDDL   ,NDOF   ,DIAG_K ,
     .                  MS     ,IN      ,HHT_A  ,WEIGHT ,IADK   ,
     .                  LT_K   )
C
        IF (IKPRES>0.AND.NBUCK==0)
     1    CALL IMP_KPRES(IBCL  ,FORC   ,NPC   ,TF    ,X     ,
     2                   SKEW  ,NSENSOR,SENSOR_TAB,WEIGHT,IADS_F,
     3                   IDDL  ,NDOF   ,IADK  ,JDIK  ,DIAG_K,
     4                   LT_K  )
         IF(IAUTSPC>0) THEN
          IF(NCYCLE==1.AND.IMCONV==1.AND.I_IMP(5)==0) THEN
              ELSE
               CALL GET_NSPC(NSPC_OLD)
           IF (NSPMD > 1) CALL SPMD_MAX_I(NSPC_OLD)
              END IF
             ENDIF
          CALL UPD_GLOB_K(
     1    ICODT     ,ICODR     ,ISKEW     ,IBFV      ,NPC       ,
     2    TF        ,VEL       ,XFRAME    ,
     3    RBY       ,X         ,SKEW      ,LPBY      ,NPBY      ,
     4    ITAB      ,WEIGHT    ,MS        ,IN        ,NRBYAC    ,
     5    IRBYAC    ,NSC       ,IKINW(LI1),NMC       ,IKINW(LI2),
     6    IKINW(LI3),IKINW(LI4),NINT2     ,IINT2     ,IKINW(LI8),
     7    IKINW(LI5),IKINW(LI6),IKINW(LI7),IPARI     ,INTBUF_TAB,
     8    NDDL      ,NNZK      ,IADK      ,JDIK      ,
     9    DIAG_K    ,LT_K      ,NDOF      ,IDDL      ,IKC       ,
     A    D_IMP     ,LB        ,NKUD      ,IKUD      ,BKUD      ,
     B    NMC2      ,IKINW(LI12),NT_RW    ,DR_IMP    ,DIRUL     ,
     C    IRBE3     ,LRBE3     ,FRBE3     ,IKINW(LI13),IRBE2    ,
     D    LRBE2     ,IKINW(LI14),IKINW(LI15))
C
          anew_stif = 'Y'
c
          IF (IMACH==3.AND.NSPMD>1) THEN
          CALL UPD_FR_K(
     1    IADK     ,JDIK     ,NDOF      ,IKC      ,IDDL     ,
     2    INLOC    ,FR_ELEM  ,IAD_ELEM  ,NDDL     )
C
          CALL WEIGHTDDL(IDDL  ,NDOF  ,IKC  ,WEIGHT ,W_DDL  ,INLOC )
         ENDIF
C--------case autospc---------
         IF(IAUTSPC>0) THEN
          IF(NCYCLE==1.AND.IMCONV==1.AND.I_IMP(5)==0) THEN
              ELSE
               CALL GET_NSPC(NSPC)
           IF (NSPMD > 1) CALL SPMD_MAX_I(NSPC)
               IF (NSPC/=NSPC_OLD) THEN
                IMCONV=-2
            IF (ISPMD==0) THEN
             WRITE(IOUT,1012)NSPC_OLD,NSPC
             WRITE(ISTDO,1012)NSPC_OLD,NSPC
            ENDIF
                CALL PUT_NSPC(NSPC_OLD)
               ENDIF
              END IF
             ENDIF
C
         IF (N_PAT>1) THEN
          CALL FIL_SPAN1(NRBYAC,IRBYAC,NPBY,IDDL,NDDL,IKC,NDOF,INLOC)
         ENDIF
C
         IF(NCYCLE==1.AND.IMCONV==1.AND.I_IMP(5)==0) THEN
C--------case mono-domain, Multi-domain NDDL_G is set inside PR_INFOK            
                  NDDL_G = NDDL
          CALL PR_INFOK(NDDL0,NNZK0,NDDL,NNZK,MAX(NNMAX,NKMAX))
C
          IF (IPREC>4) THEN
           CALL K_BAND(NDDL,IADK,JDIK,IBID)
               MAXB = MIN(MAXB,IBID)
           IF (MAXB>10000) THEN
            CALL M_LNZ(NDDL,IADK,JDIK,MAXB,MAX_L)
           ENDIF
          ENDIF
C
          NTMP = (TSTOP-TT)/DT2
          IF (NTMP>=2) THEN
           IDSGAP = 1
          ELSE
           IDSGAP = 0
          ENDIF
C
          IF (ISOLV==7) THEN
           CALL CRIT_LLIM(NDDL,NNZK)
          END IF
C
          IF (NSPMD == 1) THEN
           DO I=1,NDDL
            W_DDL(I)=1
           ENDDO
          ENDIF
          IF (IMCONV/=-2)CALL INI_K0H(NDDL,NNZK,NNZK,IADK,JDIK)
C
         ENDIF
C
         IF (NINT7<=0.AND.IMCONV==1.AND.NSPMD==1)
     .    CALL IMP_CHECK(ITAB  ,NDDL  ,IDDL  ,DIAG_K  ,NDOF  ,
     .                   IKC   ,INLOC ,NDDL0 )
C
         IF (IMON>0) CALL STOPTIME(31,1)
!         IF(IMACH/=3.OR.ISPMD==0) THEN
c          IF (NCYCLE==1.AND.IMCONV==1)THEN
c           IF (ILINE/=1)THEN
c            WRITE(IOUT,1005)N_LIM
c            WRITE(ISTDO,1005)N_LIM
c            WRITE(IOUT,*)
c            WRITE(ISTDO,*)
c           ENDIF
c          ELSEIF(INPRINT/=0) THEN
c           WRITE(IOUT,1003)
c           IF (INPRINT<0)WRITE(ISTDO,1003)
c          ENDIF
!         END IF
C
         IF (ISOLV==4.OR.ISOLV==6) THEN
            CALL ARRET(5)
         ENDIF
C-----------------------------
citask0         END IF !(ITASK == 0) THEN
C-----------------------------
c      CALL MY_BARRIER
C     ---------------
         IF (IMCONV==-2.AND.ILINE==0) THEN
          IF (NINT7 > 0) NINT7=0
          GOTO 100
         END IF
        ENDIF !IF (ISETK ==1 )
C-----------------------------
citask0       IF (ITASK == 0) THEN
C-----------------------------
        IF (IQSTAT>0) THEN
         CALL QSTAT_INI(NDDL   ,INLOC  ,IDDL    ,NDOF   ,IKC    ,
     .                  MS     ,IN     )
        ENDIF
C----------------------------------
C       MATRICE DE RIGIDITE D'INTERFACE
C----------------------------------
        GAP=EP20
        IF (NINT7>0) THEN
          L1=LSIZE(1)
          L2=LSIZE(2)
          LNSS2=0
          LNSS=0
          IF (IMON>0) CALL STARTIME(31,1)
          CALL SAV_INTTD(NINT7,NUM_IMP,NS_IMP(1+NT_IMP5),
     1                   NE_IMP(1+NT_IMP5),IND_IMP,NUM_IMP1)
C
          IF (IMP_INT==1) CALL IDEL_INT(
     1    IPARI     ,INTBUF_TAB,NUM_IMP   ,NS_IMP    ,NE_IMP    ,
     2    IND_IMP   ,NDOF      ,NINT7     )
C
          CALL DIM_INT_K(
     1    IPARI     ,INTBUF_TAB,NUM_IMP   ,NS_IMP    ,NE_IMP    ,
     2    NPBY      ,LPBY      ,ITAB      ,NRBYAC    ,IRBYAC    ,
     3    LNSS      ,NINT2     ,IINT2     ,IAINT2    ,LNSS2     ,
     4    NDDLI     ,NNZI      ,IDDLI     ,NDOFI     ,N_IMPN    ,
     5    N_IMPM    ,NNMAX     ,NKMAX     ,NDOF      ,NSREM     ,
     6    IRBE3     ,LRBE3     ,LNSS3     ,IRBE2     ,LRBE2     ,
     7    LNSB2     ,LNSRB2    ,IND_IMP  )
           ALLOCATE(IADI0(NDDLI+1))
           ALLOCATE(ITOK(NDDLI))
           ALLOCATE(JDII0(NNZI))
           ALLOCATE(NSS2(L2),NSS3(NRBE3),NSB2(LNSRB2))
           NSB2=0
           ALLOCATE(ISS2(LNSS2),ISS3(LNSS3),ISB2(LNSB2))
           ALLOCATE(NSS(L1))
           ALLOCATE(ISS(LNSS))
C
           DO I=1,L1
            NSS(I)=0
           ENDDO
C
           CALL IND_INT_K(
     1     IPARI     ,INTBUF_TAB,NUM_IMP   ,NS_IMP    ,NE_IMP      ,
     2     NPBY      ,LPBY      ,ITAB      ,NRBYAC    ,IRBYAC      ,
     3     NSS       ,ISS       ,NINT2     ,IINT2     ,NSS2        ,
     4     ISS2      ,NDDLI     ,NNZI      ,IADI0     ,JDII0       ,
     5     IDDLI     ,NDOFI     ,N_IMPN    ,ITOK      ,IDDL        ,
     6     NNMAX     ,NKMAX     ,N_IMPM    ,NDOF      ,IAINT2      ,
     7     IRBE3     ,LRBE3     ,NSS3      ,ISS3      ,IRBE2       ,
     8     LRBE2     ,NSB2      ,ISB2      ,IND_IMP  )
           ALLOCATE(DIAG_I0(NDDLI))
           ALLOCATE(LT_I0(NNZI))
           CALL ZERO1(DIAG_I0,NDDLI)
           CALL ZERO1(LT_I0,NNZI)
C
           IF (NSREM>0) THEN
            CALL IMP_FR7I(IPARI ,INTBUF_TAB,NUM_IMP ,NS_IMP ,NSREM ,
     1                     NBINTC,INTLIST)
            IF (INTP_C>0)
     1      CALL IND_FRKD(
     2      IPARI     ,INTBUF_TAB,NUM_IMP   ,NS_IMP    ,NE_IMP    ,
     3      IDDLI     ,IKC       ,NDOF      ,NSREM     ,IND_IMP  )
           ENDIF
C
           NDDL_L = NDDLI
Ctmp-------A n'est pas modifie ici -------------------
           IF (ILINTF>0) THEN
           CALL IMP_INT_K(A     ,V         ,
     1     ICODT     ,ICODR     ,ISKEW     ,IBFV      ,NPC       ,
     2     TF        ,VEL       ,NSENSOR   ,SENSOR_TAB,XFRAME    ,
     3     RBY       ,XI_C      ,SKEW      ,LPBY      ,NPBY      ,
     4     ITAB      ,WEIGHT    ,MS        ,IN        ,NRBYAC    ,
     5     IRBYAC    ,NSS       ,ISS       ,IPARI     ,INTBUF_TAB,
     6     NINT2     ,IINT2     ,IAINT2    ,NSS2      ,
     7     ISS2      ,NDDLI     ,NNZI      ,IADI0     ,JDII0     ,
     8     DIAG_I0   ,LT_I0     ,IDDLI     ,NDDL0     ,IADK      ,
     9     JDIK      ,IKC       ,DIAG_K    ,LT_K      ,IDDL      ,
     A     NUM_IMP   ,NS_IMP    ,NE_IMP    ,IND_IMP   ,NDOFI     ,
     B     ITOK      ,D_IMP     ,LB        ,GAP       ,DIRUL     ,
     C     NT_RW     ,NUM_IMP1  ,IRBE3     ,LRBE3     ,FRBE3     ,
     D     NSS3      ,ISS3      ,IRBE2     ,LRBE2     ,NSB2      ,
     E     ISB2      )
           ELSEIF (ISMDISP>0.AND.ILINE==0) THEN
           CALL IMP_INT_K(A     ,V         ,
     1     ICODT     ,ICODR     ,ISKEW     ,IBFV      ,NPC       ,
     2     TF        ,VEL       ,NSENSOR   ,SENSOR_TAB,XFRAME    ,
     3     RBY       ,X_A       ,SKEW      ,LPBY      ,NPBY      ,
     4     ITAB      ,WEIGHT    ,MS        ,IN        ,NRBYAC    ,
     5     IRBYAC    ,NSS       ,ISS       ,IPARI     ,INTBUF_TAB,
     6     NINT2     ,IINT2     ,IAINT2    ,NSS2      ,
     7     ISS2      ,NDDLI     ,NNZI      ,IADI0     ,JDII0     ,
     8     DIAG_I0   ,LT_I0     ,IDDLI     ,NDDL0     ,IADK      ,
     9     JDIK      ,IKC       ,DIAG_K    ,LT_K      ,IDDL      ,
     A     NUM_IMP   ,NS_IMP    ,NE_IMP    ,IND_IMP   ,NDOFI     ,
     B     ITOK      ,D_IMP     ,LB        ,GAP       ,DIRUL     ,
     C     NT_RW     ,NUM_IMP1  ,IRBE3     ,LRBE3     ,FRBE3     ,
     D     NSS3      ,ISS3      ,IRBE2     ,LRBE2     ,NSB2      ,
     E     ISB2      )
           ELSE
           CALL IMP_INT_K(A     ,V         ,
     1     ICODT     ,ICODR     ,ISKEW     ,IBFV      ,NPC       ,
     2     TF        ,VEL       ,NSENSOR   ,SENSOR_TAB,XFRAME    ,
     3     RBY       ,X         ,SKEW      ,LPBY      ,NPBY      ,
     4     ITAB      ,WEIGHT    ,MS        ,IN        ,NRBYAC    ,
     5     IRBYAC    ,NSS       ,ISS       ,IPARI     ,INTBUF_TAB,
     6     NINT2     ,IINT2     ,IAINT2    ,NSS2      ,
     7     ISS2      ,NDDLI     ,NNZI      ,IADI0     ,JDII0     ,
     8     DIAG_I0    ,LT_I0    ,IDDLI     ,NDDL0     ,IADK      ,
     9     JDIK      ,IKC       ,DIAG_K    ,LT_K      ,IDDL      ,
     A     NUM_IMP   ,NS_IMP    ,NE_IMP    ,IND_IMP   ,NDOFI     ,
     B     ITOK      ,D_IMP     ,LB        ,GAP       ,DIRUL     ,
     C     NT_RW     ,NUM_IMP1  ,IRBE3     ,LRBE3     ,FRBE3     ,
     D     NSS3      ,ISS3      ,IRBE2     ,LRBE2     ,NSB2      ,
     E     ISB2      )
           ENDIF
          IF (IMON>0) CALL STOPTIME(31,1)
C
           DEALLOCATE(NSS2,NSS3,NSB2)
           DEALLOCATE(ISS2,ISS3,ISB2)
           DEALLOCATE(NSS)
           DEALLOCATE(ISS)
C
          IF (NDDLI>0) THEN
C
               IFIF = 0
           IF (ILINTF>0) THEN
            IFIF = NDDLIF
            CALL SAVE_KIF(NDDLI ,IADI0 ,JDII0 ,DIAG_I0,LT_I0   ,
     1                    ITOK  ,NDDL)
           ENDIF
           IF (IFIF>0) THEN
            NDDLI = NDDLIF
            ALLOCATE(IADI(NDDLI+1))
                NNZI = IADIF(NDDLI+1)-IADIF(1)
            ALLOCATE(JDII(NNZI))
            DEALLOCATE(ITOK)
            ALLOCATE(ITOK(NDDLI))
            CALL CP_INT_HP(NDDLI+1,IADIF,IADI)
            CALL CP_INT_HP(NDDLI,IFTOK,ITOK)
            CALL CP_INT_HP(NNZI,JDIIF,JDII)
            ALLOCATE(DIAG_I(NDDLI))
            ALLOCATE(LT_I(NNZI)) 
            CALL CP_REAL_HP(NDDLI,DIAG_IF,DIAG_I)
            CALL CP_REAL_HP(NNZI,LT_IF,LT_I)
               ELSE
C
            ALLOCATE(IADI(NDDLI+1))
            ALLOCATE(JDII(NNZI))
            CALL CP_INT_HP(NDDLI+1,IADI0,IADI)
            CALL CP_INT_HP(NNZI,JDII0,JDII)
            ALLOCATE(DIAG_I(NDDLI))
            ALLOCATE(LT_I(NNZI))
            CALL CP_REAL_HP(NDDLI,DIAG_I0,DIAG_I)
            CALL CP_REAL_HP(NNZI,LT_I0,LT_I)
C
           ENDIF
           DEALLOCATE(IADI0)
           DEALLOCATE(JDII0)
           DEALLOCATE(DIAG_I0)
           DEALLOCATE(LT_I0)
C
           IF (ISOLV==4.OR.ISOLV==6) THEN
             CALL ARRET(5)
           ENDIF
C
          ELSE
           ALLOCATE(IADI(1))
           ALLOCATE(JDII(1))
           DEALLOCATE(IADI0)
           DEALLOCATE(JDII0)
           ALLOCATE(DIAG_I(1))
           ALLOCATE(LT_I(1))
           DEALLOCATE(DIAG_I0)
           DEALLOCATE(LT_I0)
          ENDIF
C
C         Store the size of the contact stifness matrix for nonlinear solver outputs            
          IF ((NSPMD==1.OR.NBINTC==0).AND.IMCONV>=0) I_IMP(13) = NDDLI
          IF ((NSPMD==1.OR.NBINTC==0).AND.IMCONV>=0.AND.
     .         (LPRINT/=0.OR.NPRINT/=0)) THEN
            WRITE(IOUT,1006)
            WRITE(ISTDO,1006)
            WRITE(IOUT,1007)NDDLI,NNZI !,NNMAX
            WRITE(ISTDO,1007)NDDLI,NNZI !,NNMAX
c            WRITE(IOUT,*)
c            WRITE(ISTDO,*)
          ENDIF
        ENDIF
C----------------------------------
        IF (NFXVEL/=0.AND.IMCONV==1) THEN
          CALL FV_IMP1(NKUD   ,IKUD    ,BKUD    ,LB    )
          CALL FVBC_IMPL1(IBFV   ,SKEW  ,XFRAME ,DIRUL ,IDDL   ,
     1                    IKC    ,NDOF  ,D_IMP  ,DR_IMP,ICODT  ,
     3                    ICODR  ,ISKEW )
        ENDIF
C-------------initialization of Fext---for Riks-->approximation for follower load
C         IF (NCYCLE==1.AND.IDTC==3.AND.IMCONV==1.AND.
         IF (IDTC==3.AND.IMCONV==1.AND.
     .       I_IMP(5)==0) THEN
            CALL GET_FEXT(NDDL0 ,NDDL   ,IDDL   ,NDOF   ,IKC   ,
     1                    INLOC ,LB     ,FEXT   ,AC     ,ACR   )
              R_IMP(13) = TSTOP-TT+DT2
C             R_IMP(13) = SQRT(R2)
         END IF
        IF (IDYNA>0.AND.IDY_DAMP>0) THEN
          CALL IMP_DYKV(NODFT  ,NODLT   ,IDDL   ,NDOF   ,IKC    ,
     .                  DIAG_K ,IADK    ,JDIK   ,LT_K   ,WEIGHT ,
     1                  RBY    ,X       ,SKEW   ,LPBY   ,NPBY   ,
     2                  NRBYAC ,IRBYAC  ,NINT2  ,IINT2  ,IPARI  ,
     3                  INTBUF_TAB      ,IRBE3  ,LRBE3  ,FRBE3  ,
     4                  IRBE2  ,LRBE2   ,V      ,VR     ,NDDL0  ,
     5                  FR_ELEM,IAD_ELEM,MS     ,IN     )
        END IF
C-------------LB,A,AR devient Fext-Fint---------------------

         CALL UPD_RHS(ICODT ,ICODR ,ISKEW ,IBFV    ,XFRAME ,
     1               RBY   ,X     ,SKEW   ,LPBY   ,NPBY   ,
     2               NRBYAC,IRBYAC,NINT2  ,IINT2  ,IPARI  ,
     3               INTBUF_TAB   ,NDOF   ,IDDL   ,IKC    ,
     4               NDDL0 ,LB    ,ISETK  ,INLOC  ,DIRUL  ,
     5               A     ,AR    ,AC     ,ACR    ,NT_RW  ,
     6               IRFLAG,W_DDL ,NDDL   ,R_IMP(1),IDYNA ,
     7               V     ,VR    ,MS     ,IN     ,IRBE3  ,
     8               LRBE3 ,FRBE3 ,WEIGHT ,IRBE2  ,LRBE2  )
C
        IF (IMACH==3.AND.NSPMD>1) THEN
          ICONTA = NDDLI + NSREM
          CALL SPMD_MAX_I(ICONTA)
         IF (NBINTC>0.) THEN
          CALL SPMD_MIN_S(GAP)
          IF (ICONTA> 0.AND.GAP>ZERO) THEN
C
           CALL SPMD_MAX_I(IFDIS)
           IF (ILINTF>0) THEN
            CALL IMP_INTFR(
     1    NUM_IMP   ,NS_IMP    ,NE_IMP    ,IPARI     ,INTBUF_TAB,
     2    NPBY      ,LPBY      ,ITAB      ,NRBYAC    ,
     3    IRBYAC    ,NINT2     ,IINT2     ,IDDL      ,IKC       ,
     4    NDOF      ,INLOC     ,NSREM     ,NSL       ,NBINTC    ,
     5    INTLIST   ,XI_C      ,IBFV      ,DIRUL     ,SKEW      ,
     6    XFRAME    ,ISKEW     ,ICODT     ,R_IMP(16) ,D_IMP     ,
     7    LB        ,IFDIS     ,NDDL      ,DR_IMP    ,IDDLI     ,
     8    IRBE3     ,LRBE3     ,FRBE3     ,IRBE2     ,LRBE2     ,
     9    DD        ,DDR       ,A         ,AR        ,AC        ,
     A    ACR       ,MS        ,V         ,NDDL0     ,R_IMP(1)  ,
     B    RBY       ,ICODR     ,NT_RW     ,W_DDL     ,WEIGHT    ,
     C    IRFLAG    )
           ELSEIF (ISMDISP>0.AND.ILINE==0) THEN
            CALL IMP_INTFR(
     1    NUM_IMP   ,NS_IMP    ,NE_IMP    ,IPARI     ,INTBUF_TAB,
     2    NPBY      ,LPBY      ,ITAB      ,NRBYAC    ,
     3    IRBYAC    ,NINT2     ,IINT2     ,IDDL      ,IKC       ,
     4    NDOF      ,INLOC     ,NSREM     ,NSL       ,NBINTC    ,
     5    INTLIST   ,X_A       ,IBFV      ,DIRUL     ,SKEW      ,
     6    XFRAME    ,ISKEW     ,ICODT     ,R_IMP(16) ,D_IMP     ,
     7    LB        ,IFDIS     ,NDDL      ,DR_IMP    ,IDDLI     ,
     8    IRBE3     ,LRBE3     ,FRBE3     ,IRBE2     ,LRBE2     ,
     9    DD        ,DDR       ,A         ,AR        ,AC        ,
     A    ACR       ,MS        ,V         ,NDDL0     ,R_IMP(1)  ,
     B    RBY       ,ICODR     ,NT_RW     ,W_DDL     ,WEIGHT    ,
     C    IRFLAG    )
           ELSE
            CALL IMP_INTFR(
     1    NUM_IMP   ,NS_IMP    ,NE_IMP    ,IPARI     ,INTBUF_TAB,
     2    NPBY      ,LPBY      ,ITAB      ,NRBYAC    ,
     3    IRBYAC    ,NINT2     ,IINT2     ,IDDL      ,IKC       ,
     4    NDOF      ,INLOC     ,NSREM     ,NSL       ,NBINTC    ,
     5    INTLIST   ,X         ,IBFV      ,DIRUL     ,SKEW      ,
     6    XFRAME    ,ISKEW     ,ICODT     ,R_IMP(16) ,D_IMP     ,
     7    LB        ,IFDIS     ,NDDL      ,DR_IMP    ,IDDLI     ,
     8    IRBE3     ,LRBE3     ,FRBE3     ,IRBE2     ,LRBE2     ,
     9    DD        ,DDR       ,A         ,AR        ,AC        ,
     A    ACR       ,MS        ,V         ,NDDL0     ,R_IMP(1)  ,
     B    RBY       ,ICODR     ,NT_RW     ,W_DDL     ,WEIGHT    ,
     C    IRFLAG    )
           END IF !(ILINTF>0) THEN
C
          CALL GETNDDLI_G(
     1    NPBY      ,LPBY      ,ITAB      ,NRBYAC    ,IRBYAC    ,
     2    NINT2     ,IINT2     ,IPARI     ,INTBUF_TAB,NDOFI     ,
     3    NDOF      ,IKC       ,IDDL      ,FR_ELEM   ,IAD_ELEM  ,
     4    NDDLI     ,NSL       ,NDDLI_G   ,IRBE3     ,LRBE3     ,
     5    IRBE2     ,LRBE2     )
C         Store the size of the contact stifness matrix for nonlinear solver outputs            
          IF (ISPMD==0.AND.IMCONV>=0) I_IMP(13) = NDDLI_G     
            IF (ISPMD==0.AND.IMCONV>=0.AND.
     .         (LPRINT/=0.OR.NPRINT/=0)) THEN
             WRITE(IOUT,1006)
             WRITE(ISTDO,1006)
             WRITE(IOUT,1011)NDDLI_G
             WRITE(ISTDO,1011)NDDLI_G
             WRITE(IOUT,*)
             WRITE(ISTDO,*)             
            ENDIF
          ENDIF
         ENDIF
        ENDIF
C
        IF (INTP_C<0) THEN
            CALL KIN_KNL(
     1    IPARI     ,INTBUF_TAB,NUM_IMP   ,NS_IMP    ,NE_IMP    ,
     2    NPBY      ,LPBY      ,ITAB      ,NRBYAC    ,IRBYAC    ,
     3    NINT2     ,IINT2     ,IBFV      ,DIRUL     ,ISKEW     ,
     6    ICODT     ,NDOFI     ,IDDL      ,IKC       ,NDOF      ,
     5    INLOC     ,IRBE3     ,LRBE3     ,FRBE3     ,X         ,
     6    SKEW      ,IRBE2     ,LRBE2)
        ENDIF
C
          IF (NMONV>0.AND.ISETK==1) CALL MONV_IMP(
     .     MONVOL ,VOLMON  ,X      ,IGRSURF  ,
     1     NMONV  ,IMONV   ,IPARI  ,INTBUF_TAB      ,
     2     A      ,AR      ,NDOF   ,IDDL   ,IKC     ,
     3     INLOC  ,ILINE   ,IBFV   ,SKEW   ,XFRAME  ,
     4     DIRUL  ,ISKEW   ,ICODT  ,IRBE3   ,LRBE3  ,
     5     FRBE3  ,IRBE2   ,LRBE2  ,NSURF)
C
        IF (GAP<ZERO) THEN
         IMCONV = -2
          IF (IMACH/=3.OR.ISPMD==0) THEN
           WRITE(IOUT,1009)INT(-GAP)
           WRITE(ISTDO,1009)INT(-GAP)
          ENDIF
        ENDIF
C------------
        IF (ISPRB==1.AND.IMCONV==1) THEN
          DO I=1,NDDL
            LB0(I) = LB(I)
          ENDDO
        ENDIF
C
        IF (ISIGINI==1.AND.NCYCLE==1.AND.IMCONV==1) THEN
         CALL CONDENS_B(NDDL0  ,IKC  ,LB0  )
        ENDIF
C---------for mono
        NDDLI_G=MAX(NDDLI_G,NDDLI)
        ICONTA = MAX(ICONTA,NDDLI_G)
         IF (ICONTA>0) THEN
              IF (ISOLV<5) IDSC = 1
             ENDIF
C
         IF (ILINTF>2.AND.NCYCLE<ILINTF) THEN
          NSREM = 0
          NSL = 0
         ENDIF
C
         IF (ILINTF>0.AND.NDDLI==0) THEN
           IF (NDDLIF>0) THEN
            NDDLI = NDDLIF
            IF (ALLOCATED(IADI)) DEALLOCATE(IADI)
            ALLOCATE(IADI(NDDLI+1))
            NNZI = IADIF(NDDLI+1)-IADIF(1)
            IF (ALLOCATED(JDII)) DEALLOCATE(JDII)
            ALLOCATE(JDII(NNZI))
            IF (ALLOCATED(ITOK)) DEALLOCATE(ITOK)
            ALLOCATE(ITOK(NDDLI))
            CALL CP_INT_HP(NDDLI,IFTOK,ITOK)
            CALL CP_INT_HP(NDDLI+1,IADIF,IADI)
            CALL CP_INT_HP(NNZI,JDIIF,JDII)
            IF (ALLOCATED(DIAG_I)) DEALLOCATE(DIAG_I)
            ALLOCATE(DIAG_I(NDDLI))
            IF (ALLOCATED(LT_I)) DEALLOCATE(LT_I)
            ALLOCATE(LT_I(NNZI))
            CALL CP_REAL_HP(NDDLI,DIAG_IF,DIAG_I)
            CALL CP_REAL_HP(NNZI,LT_IF,LT_I)
           ENDIF
         ENDIF
C
          R_IMP(18)=GAP
C
         IF (IQSTAT>0.AND.ILINTF>0.AND.ILINTF==NCYCLE)
     .      CALL IMP_QIFAM(NODFT  ,NODLT   ,IDDL   ,NDOF   ,INLOC ,
     .                     IKC    ,DIAG_K  ,MS     ,IN     ,WEIGHT)
C
C        WRITE(6,*) IMUMPSV,IDSC,IMCONV
#if defined(MUMPS5) 
         IF (IMUMPSV >0 .AND.IDSC==1.AND.IMCONV>=0)
     .     CALL IMP_MUMPS1(NDDL0,   NNZK0,     NDDL,   NNZK,  NNMAX,
     .                     NODGLOB, IDDL,      NDOF,   INLOC, IKC,
     .                     IADK,    JDIK,      DIAG_K, LT_K,  IAD_ELEM,
     .                     FR_ELEM, MUMPS_PAR, CDDLP,  IADI,  JDII,
     .                     ITOK,    DIAG_I,    LT_I,   NDDLI, NNZI    ,
     .                     IPRINT0, IT )
#else
        WRITE(6,*) "Fatal error: MUMPS is required"
        CALL FLUSH(6)
        CALL ARRET(5)
#endif
            CALL CP_REAL_HP(NDDL,LB,LBB)
C--------PCG w/ Projection----
         IF(NCYCLE==1.AND.IMCONV==1.AND.I_IMP(5)==0) THEN
          IF (M_VS> 0) THEN
C-------------Case smll model---
           NPCGPV=NDDL
           IF (NSPMD>1)CALL SPMD_MIN_I(NPCGPV)
           M_VS=MIN(M_VS,NPCGPV)
           IF (M_VS> 0) NPCGPV=-1
          END IF
C---------for free rigi motion for springback(generalization later)           
          IF(IRIG_M>0) THEN
             CALL SPBRM_PRE(ITAB ,
     1            X         ,IPARG     ,IXC       ,IXTG      ,PARTSAV   ,
     2            ELBUF_TAB ,PM        ,NDOF      ,IDDL      ,IKC       )
          END IF
         END IF
C-----------------------------
        IF (ICONTA>0) ISETP = 1
C----------------------------------
C       IMPLICIT RESOLVE
C----------------------------------
 100    CONTINUE
C
       IF (ILINE==1) THEN
         IF (NCYCLE==1.AND.ISPMD==0.AND.ITASK==0) THEN
              IF (IQSTAT>0) THEN
           WRITE(IOUT,*)
           WRITE(IOUT,*)' ** BEGIN LINEAR QUASI-STATIC IMPLICIT COMPUTATION **'
           WRITE(ISTDO,*)
           WRITE(ISTDO,*)' ** BEGIN LINEAR QUASI-STATIC IMPLICIT COMPUTATION **'
           WRITE(IOUT,*)
           WRITE(ISTDO,*)
              ELSE
           WRITE(IOUT,*)
          WRITE(IOUT,*)' ** BEGIN LINEAR STATIC IMPLICIT COMPUTATION **'
           WRITE(ISTDO,*)
         WRITE(ISTDO,*)' ** BEGIN LINEAR STATIC IMPLICIT COMPUTATION **'
           WRITE(IOUT,*)
           WRITE(ISTDO,*)
              END IF !(IQSTAT>0) THEN
         ENDIF
C
          NTMP=0
C
c          R2=ZERO          
          CALL PRODUT_HP(NDDL,LB,LB,W_DDL,R2)
C
          IF (R2>ZERO.AND.R2<EP30) THEN
          ELSEIF(IQSTAT==0.AND.ITASK==0.AND.NDDL>0) THEN
           CALL IMP_STOP(0)
          ENDIF
C
          CALL LIN_SOLV(NDDL  ,IDDL  ,NDOF   ,IKC   ,D_IMP ,
     1                 DR_IMP,L_TOL ,NNZK   ,IADK  ,JDIK  ,
     2                 DIAG_K,LT_K   ,NDDLI  ,IADI  ,JDII  ,
     3                 DIAG_I,LT_I   ,ITOK   ,IADM  ,JDIM  ,
     4                 DIAG_M,LT_M   ,LB    ,R_IMP(6),INLOC ,
     5                 FR_ELEM,IAD_ELEM,W_DDL,ITASK ,ISETP  ,
     6                 ISTOP  ,A     ,AR     ,V    ,
     7                 MS    ,X     ,IPARI ,INTBUF_TAB   ,
     8                 NUM_IMP,NS_IMP,NE_IMP,NSREM ,NSL  ,
     9                 NTMP  ,GRAPHE, ITAB  ,RBID  ,IBID ,
     A                 IBID  ,NMONV ,IMONV  ,MONVOL,IGRSURF,
     B                 FR_MV ,VOLMON,IBFV  ,SKEW  ,
     C                 XFRAME,MUMPS_PAR,CDDLP,IND_IMP,XI_C,
     D                 IRBE3 ,LRBE3 ,IRBE2  ,LRBE2 )

C-----------------------------
citask0        IF (ITASK == 0) THEN
C-----------------------------
         IF (INEGA>0) THEN
          CALL IDDL2NOD(NDDL  ,IDDL  ,NDOF  ,IKC   ,INLOC ,
     .                  INEGA ,NNOD  )
          IF (NNOD>0) THEN
           WRITE(IOUT,1008)ITAB(NNOD)
           WRITE(ISTDO,1008)ITAB(NNOD)
          ENDIF
C
         ELSEIF(IPREC>1.AND.ISOLV<=2) THEN
          CALL IMP_CHECM(ITAB  ,NDDL  ,IDDL  ,DIAG_M  ,NDOF  ,
     .                   IKC   ,INLOC ,NDDL0 )
C
         ENDIF
         IF(NFXV_G/=0.AND.(NSREM+NSL-INTP_C)>0) THEN
          CALL FV_IMP(IBFV  ,NPC    ,TF     ,VEL   ,SENSOR_TAB,
     1                D_IMP  ,DR_IMP ,IKC   ,IDDL  ,NSENSOR   ,
     2                SKEW  ,IFRAME ,XFRAME ,V     ,VR    ,
     3                X     ,DIRUL  ,NDOF   ,A     ,AR    )
         ENDIF
         CALL RECUKIN(RBY   ,LPBY  ,NPBY  ,SKEW  ,ISKEW ,
     1                ITAB  ,WEIGHT,MS    ,IN    ,
     2                IBFV  ,VEL   ,ICODT,ICODR ,
     3                NRBYAC,IRBYAC,NINT2 ,IINT2 ,IPARI ,
     4                INTBUF_TAB   ,NDOF  ,D_IMP ,DR_IMP,
     5                X     ,XFRAME,DIRUL ,IXR   ,IXC   ,
     6                IXTG  ,SH4TREE,SH3TREE,IRBE3 ,LRBE3,
     7                FRBE3 ,IRBE2 ,LRBE2 )
          IF (ISTOP>0) CALL IMP_STOP(-1)
          CALL INTEGRATORL_HP(D_IMP ,DR_IMP,
     1                        X    ,V    ,VR    ,A     ,AR    )
C
c         IF (IMPDEB>0) THEN
c            CALL PR_DEB(NDDL  ,IDDL  ,NDOF   ,IKC   ,ITAB   , 
c     1                  DIAG_K,DIAG_M,INLOC  ,FR_ELEM,IAD_ELEM,
c     2                  IADK  ,JDIK  ,LT_K   ,LT_M   ,NDDLI  ,
c     3                  IADI  ,JDII  ,ITOK   ,DIAG_I ,LT_I   ,
c     4                  LBB   ,LBB   ,0      ,NSREM  ,NSL    ,
c     5                  D_IMP ,DR_IMP,1      ,W_DDL  ,AC     ,
c     6                  ACR   ,A     ,AR     ,R2     ,0  ,NODGLOB) 
c         END IF
         IF (ILINTF>0.AND.NCYCLE<ILINTF) THEN
          CALL IMP_INTTD0(
     1       IPARI ,INTBUF_TAB    ,X_A     ,D       ,
     2       MS    ,ITAB   ,IN    ,D_IMP   ,DR_IMP  ,
     3       IMSCH ,I2MSCH ,ISIZXV,ILENXV  ,IGRBRIC ,
     4       ISLEN7,IRLEN7 ,ISLEN11,IRLEN11,ISLEN17 ,
     5       IRLEN17,IRLEN7T,ISLEN7T,IAD_ELEM,FR_ELEM ,
     6       NBINTC,INTLIST,ITASK  ,KINET   ,NEWFRONT,
     7       NUM_IMP,NS_IMP,NE_IMP,IND_IMP ,ISENDTO ,
     8       IRECVFROM,WEIGHT ,IXS   ,TEMP  ,
     9       DT2PREV,WAINT ,NUM_IMP1,IRLEN20,ISLEN20,
     A       IRLEN20T,ISLEN20T,IRLEN20E,ISLEN20E,
     B       IKINE,DIAG_SMS,COUNT_REMSLV,COUNT_REMSLVE,
     C       NSENSOR,SENSOR_TAB,XDP,H3D_DATA,MULTI_FVM,
     D       FORNEQS,MAXDGAP,INTERFACES)

          TT=MAX(ZERO,TT-DT2)
          ISETK =0
C-------save Fint par AC,ACR---------
         ELSE
          IF (ILINTF>0) THEN
           NT_IMP1 = 0
           DO I = 1,NINTER
            NUM_IMP1(I) = 0
           END DO
          ENDIF
C
          CALL INTEGRATOR1_HP(D_IMP ,D    )
          IF ((ISUB>0.OR.ISECUT>0.OR.IISROT>0
     .      .OR.ISHSUB/=0.OR.IMPOSE_DR/=0 .OR. IDROT==1)
     .      .AND. IRODDL/=0) THEN
           CALL INTEGRATOR1_HP(DR_IMP,DR)
          ENDIF
C
          IF (ISCAU>0)CALL INTEGRATOR1_HP(D_IMP ,X    )
         ENDIF
         CALL INTEGRATOR1_HP(D_IMP ,X_A   )
C-----------------------------
citask0        END IF !(ITASK == 0) THEN
C-----------------------------
       ELSE  !  nonlinear
C-------------------------
C        IF (GAP<ZERO) GOTO 300
        IF (R_IMP(18)<ZERO.OR.IMCONV==-2) GOTO 300
         IF (IMCONV==1) THEN
C--------valeur au debut d'increament--sauf diverge----
citask0          IF (ITASK == 0) THEN
          IF(NCY_MAX>0.AND.NCYCLE>NCY_MAX) CALL IMP_STOP(-3)
          IF (INCONV==1) THEN
           CALL CP_IMPBUF(1     ,ELBUF   ,ELBUF_C ,BUFMAT ,BUFMAT_C ,
     .                    FSAV  ,VOLMON  ,PARTSAV ,INTBUF_TAB       ,
     .                    INTBUF_TAB_C,IPARI   ,ISLEN7 ,IRLEN7   ,
     .                    ISLEN11,IRLEN11,ISLEN17 ,IRLEN17,IRLEN7T  ,
     .                    ISLEN7T,IRLEN20,ISLEN20 ,IRLEN20T,ISLEN20T,
     .          IRLEN20E,ISLEN20E,NEWFRONT,ELBUF_TAB,ELBUF_IMP,          
     .          IPARG   )          
          END IF
          IF (NCYCLE==1) THEN
           IF (ISPRB==1.AND.I_IMP(5)==0) R_IMP(1) = ZERO
           R_IMP(1) = MAX(R_IMP(1),RF_MIN*RF_MIN)
           R_IMP(1) = MIN(R_IMP(1),RF_MAX*RF_MAX)
           IF (INCONV==1) I_IMP(12)=1
          END IF
C--------case of converge with 0 iteration-------
           IF (ISMDISP>0) THEN
            CALL CP_REAL_HP(NNDL,X_A,X_C)
           ELSE
            CALL CP_REAL_HP(NNDL,X,X_C)
           END IF
           I_IMP(2)=0
           I_IMP(6)=ICONTA
           IT=0
citask0          END IF !(ITASK == 0) THEN
C
          IF (ISIGINI==1) THEN
C           TMP1 = DT2*NCYCLE
C           TMP2 = TSTOP-TT+TMP1-DT2
C           BFAC =TMP1/MAX(DT2,TMP2)
C------strickly proportional
           BFAC= (TT-R_IMP(19))/(TSTOP-R_IMP(19))
           R_IMP(10)=BFAC-ONE
           IF (R_IMP(10)<ZERO)CALL VAXPY_HP(NDDL ,LB  ,LB0  ,R_IMP(10))
          ENDIF
C
C----------------------
c      CALL MY_BARRIER
C---------------------
c          R2=ZERO
          CALL PRODUT_HP(NDDL,LB,LB,W_DDL,R2)
C----------------------
c      CALL MY_BARRIER
C---------------------
          IF (R2>=ZERO.AND.R2<EP30) THEN
          ELSEIF(IDYNA==0.AND.IQSTAT==0) THEN
           CALL IMP_STOP(0)
          ENDIF
C
          IF (INCONV == 1) R_IMP(1)=MAX(R_IMP(1),R2)
!sb
          IF(N_LIM == 1 .AND. ISPRB == 0) R_IMP(1)=R2    
!fin sb
         IF (ISPRB==1) THEN
           IF (SQRT(R2/R_IMP(1))<=N_TOL) THEN
c            IF (ITASK == 0) THEN
             DT_IMP=TSTOP-TT+DT2
             CALL ZEROR_HP(D_IMP,NUMNOD)
             IF (IRODDL/=0) CALL ZEROR_HP(DR_IMP,NUMNOD)
c            END IF !(ITASK == 0) THEN
            GOTO 200
           ENDIF
          END IF !(ISPRB==1) THEN
C
citask0          IF (ITASK == 0) THEN
C
          IF (ISPRB==1) THEN
           TMP1 = DT2*NCYCLE
           TMP2 = TSTOP-TT+TMP1-DT2
           BFAC =TMP1/MAX(DT2,TMP2)
           R_IMP(10)=BFAC-ONE
           R_IMP(2)=R2*BFAC*BFAC
           IF (NCYCLE==1) THEN
            R_IMP(12)=EM01
C
            IF (ICONTA>0) R_IMP(12)=ZEP9
           ELSE
            TMP = DT12/MAX(DT12,TSTOP-TT)+N_TOL/SQRT(R2/R_IMP(1))
            TMP = MIN(HALF*TMP,ONE)
            R_IMP(12)=R_IMP(12)*(ONE-TMP)+TMP
           ENDIF
          ELSE
           R_IMP(2)=R2
          ENDIF
          R_IMP(3)=ONE
          R_IMP(4)=R_IMP(6)
C
citask0          END IF !(ITASK == 0) THEN
C----------------------
c      CALL MY_BARRIER
C---------------------
          IF (ISPRB==1) THEN
           TMP = R_IMP(10)+ONE
           CALL VSCALY_HP(NDDL ,LB  ,LB0  ,TMP )
          END IF
         ELSEIF (IMCONV==-1) THEN
C--------line-search------
          IF (ISPRB==1.OR.ISIGINI==1) THEN
           IF (R_IMP(10)<ZERO) THEN
            CALL VAXPY_HP(NDDL ,LB  ,LB0  ,R_IMP(10))
           ENDIF
          ENDIF
         ELSE
citask0          IF (ITASK == 0) THEN
           IT=IT+1
           I_IMP(2)=I_IMP(2)+1
citask0          END IF !(ITASK == 0) THEN
          IF (ISPRB==1.OR.ISIGINI==1) THEN
           IF (R_IMP(10)<ZERO) THEN
            CALL VAXPY_HP(NDDL ,LB  ,LB0  ,R_IMP(10))
           ENDIF
          ENDIF
         ENDIF  !         IF (IMCONV==1) THEN
C----------------------
c      CALL MY_BARRIER
C---------------------
citask0        IF (ITASK == 0) THEN
C-----------------------------
         IF (ISPRB==1) THEN
          FACI=MIN(ONE,R_IMP(12))
          R02=FACI*FACI*R_IMP(1)
         ELSE
          R02=R_IMP(1)
         ENDIF
         IF (IT==1.AND.IREFI==5) THEN
              R02 = MAX(R02,EM20)
          R_IMP(6) = MAX(EM20,R_IMP(6))
             ENDIF
         IF (IT==1.AND.ICONTA>I_IMP(6)) THEN
C       re-evoluer Rref-------
          IF (IREFI==5.AND.NFXV_G>0.AND.IMCONV>=0) THEN
           CALL RER02(RBY   ,LPBY  ,NPBY  ,SKEW  ,ISKEW ,
     1                ITAB  ,WEIGHT,MS    ,IN    ,
     2                IBFV  ,VEL   ,ICODT,ICODR ,
     3                NRBYAC,IRBYAC,NINT2 ,IINT2 ,IPARI ,
     4                INTBUF_TAB   ,NDOF  ,D_IMP ,DR_IMP,
     5                X     ,XFRAME,DIRUL ,IXR   ,IXC   ,
     6                IXTG  ,SH4TREE,SH3TREE,IRBE3 ,LRBE3,
     7                FRBE3 ,IADK   ,JDIK  ,DIAG_K,LT_K ,
     8                IDDL  ,IKC    ,INLOC ,NUM_IMP,NS_IMP,
     9                NE_IMP,IND_IMP,NDDL  ,W_DDL  ,A   ,
     A                AR    ,R02    ,IRBE2 ,LRBE2  ,X_C  )
           R_IMP(1) = MAX(R02,R_IMP(1))
          ENDIF
          IF (I_IMP(7)==0.AND.IREFI==4) IREFI= -4
         ENDIF
         IF (IMCONV>0.AND.ISPRB/=1) THEN
           R02 = MAX(R02,RF_MIN*RF_MIN)
           R02 = MIN(R02,RF_MAX*RF_MAX)
         END IF
C
         IF (NCYCLE==1.AND.INSOLV>=2.AND.IT==0.AND.IMCONV>=0)
     .    CALL BFGS_INI(NDDL,N_LIM)
           R_IMP(17) = R02
C-----------------------------
citask0        END IF !(ITASK == 0) THEN
C-----------------------------
C----------------------
c      CALL MY_BARRIER
C---------------------
c-------particular case .AND.NFXVEL==0
        IF (NDDL_G==0.AND.NFXVEL > 0) THEN
         IF (IT==0) THEN
C----add 3 to enforce at least one iteration in case of IMPDISP dependent (moving skew or frame)
          IMCONV=3
          ISETK=0
         ELSE
          IMCONV=1
         END IF
C----------------------
c      CALL MY_BARRIER
C---------------------
        ELSE
         CALL NL_SOLV(NDDL  ,IDDL  ,NDOF   ,IKC   ,D_IMP ,
     1                DR_IMP,NNZK  ,IADK   ,JDIK  ,DIAG_K,
     2                LT_K  ,LB    ,NDDLI  ,IADI  ,JDII  ,
     3                DIAG_I,LT_I  ,ITOK   ,IADM  ,JDIM  ,
     4                DIAG_M,LT_M  ,R_IMP(17),DD    ,DDR   ,
     5                ITASK ,IT  ,I_IMP(2),R_IMP(3),R_IMP(2),
     6                I_IMP(5) ,INPRINT,ISETP ,ISTOP ,R_IMP(4),
     7                R_IMP(5),R_IMP(6),INLOC ,NDDL0 ,R_IMP(7),
     8                R_IMP(11),R_IMP(18),ITAB  ,FR_ELEM,IAD_ELEM,
     9                W_DDL    ,A      ,AR    ,V     ,MS    ,
     A                X        ,IPARI ,INTBUF_TAB    ,NUM_IMP,
     B                NS_IMP   ,NE_IMP,NSREM ,NSL   ,ICONTA ,
     C                GRAPHE   ,FAC_K ,IPIV_K, NKCOND,NMONV  ,
     D                IMONV ,MONVOL ,IGRSURF,FR_MV  ,
     E                VOLMON,IBFV   ,SKEW  ,XFRAME,MUMPS_PAR,
     F                CDDLP ,IND_IMP,NBINTC,INTLIST,NEWFRONT,
     G                ISENDTO,IRECVFROM,IRBE3,LRBE3,I_IMP(8),
     H                I_IMP(9),I_IMP(10),FEXT  ,DG    ,DGR  ,
     I                DG0   ,DGR0 ,R_IMP(13),R_IMP(14),
     J                NODFTSK,NODLTSK,IRBE2,LRBE2,I_IMP(12),
     K                R_IMP(20),anew_stif)
        END IF !(NDDL==0.AND.NFXVEL > 0) THEN

C---------------------------------
citask0        IF (ITASK == 0) THEN
C---------------------------------
         IF(NFXVEL/=0) THEN
C-----for FV_local
          NTMP=0
          DO I=1,NFXVEL
           NTMP=NTMP+IABS(DIRUL(I))
          END DO
          IF (NTMP>0)
     .    CALL FV_IMP(IBFV  ,NPC    ,TF     ,VEL   ,SENSOR_TAB,
     1                D_IMP  ,DR_IMP ,IKC   ,IDDL  ,NSENSOR   ,
     2                SKEW  ,IFRAME ,XFRAME ,V     ,VR    ,
     3                X     ,DIRUL  ,NDOF   ,A     ,AR    )
         END IF
C--------Rigid motions elimination----          
        IF(IRIG_M>0.AND.IMCONV==1) THEN
            CALL SPB_RM_RIG(
     1    X         ,IXC       ,IXTG      ,NDOF      ,IDDL      ,
     2    IKC       ,D_IMP     ,DR_IMP    ,ICODT     ,ICODR ,
     3    SKEW      ,ISKEW     ,itab     )
        END IF
         IF(IMP_LR > 0)THEN
           CALL RECUKIN(RBY   ,LPBY  ,NPBY  ,SKEW  ,ISKEW ,
     1                  ITAB  ,WEIGHT,MS    ,IN    ,
     2                  IBFV  ,VEL   ,ICODT,ICODR ,
     3                  NRBYAC,IRBYAC,NINT2 ,IINT2 ,IPARI ,
     4                  INTBUF_TAB,NDOF  ,D_IMP ,DR_IMP,
     5                  X_C   ,XFRAME,DIRUL ,IXR   ,IXC   ,
     6                  IXTG  ,SH4TREE,SH3TREE,IRBE3 ,LRBE3,
     7                  FRBE3 ,IRBE2 ,LRBE2 )
        ELSE
           CALL RECUKIN(RBY   ,LPBY  ,NPBY  ,SKEW  ,ISKEW ,
     1                  ITAB  ,WEIGHT,MS    ,IN    ,
     2                  IBFV  ,VEL   ,ICODT,ICODR ,
     3                  NRBYAC,IRBYAC,NINT2 ,IINT2 ,IPARI ,
     4                  INTBUF_TAB   ,NDOF  ,D_IMP ,DR_IMP,
     5                  X     ,XFRAME,DIRUL ,IXR   ,IXC   ,
     6                  IXTG  ,SH4TREE,SH3TREE,IRBE3 ,LRBE3,
     7                  FRBE3 ,IRBE2 ,LRBE2 )
        END IF
c       Print information of non-linear solver 
        IF (SOLVNFO > ZERO) THEN
         IF (IMCONV /= -1) THEN 
          CALL PR_SOLNFO(NDDL  ,IDDL  ,NDOF   ,IKC   ,ITAB   ,
     1                  DIAG_K,DIAG_M,INLOC  ,FR_ELEM,IAD_ELEM,
     2                  IADK  ,JDIK  ,LT_K   ,LT_M   ,NDDLI  ,
     3                  IADI  ,JDII  ,ITOK   ,DIAG_I ,LT_I   ,
     4                  LBB   ,LBB   ,IT     ,NSREM  ,NSL    ,
     5                  D_IMP ,DR_IMP,1      ,W_DDL  ,AC     ,
     6                  ACR   ,A     ,AR     ,R2    ,NDEB0   ,
     7                  R_IMP ,I_IMP ,DD     ,DDR)
         ENDIF       
        ENDIF  
c        
c        IF (IMPDEB>0) THEN
c          IF (NCYCLE>=NDEB0.AND.NCYCLE<=NDEB1) THEN
c            CALL PRODUT_HP(NDDL,LB,LB,W_DDL,R2)
c            CALL PR_DEB(NDDL  ,IDDL  ,NDOF   ,IKC   ,ITAB   ,
c     1                  DIAG_K,DIAG_M,INLOC  ,FR_ELEM,IAD_ELEM,
c     2                  IADK  ,JDIK  ,LT_K   ,LT_M   ,NDDLI  ,
c     3                  IADI  ,JDII  ,ITOK   ,DIAG_I ,LT_I   ,
c     4                  LBB   ,LBB   ,IT     ,NSREM  ,NSL    ,
c     5                  D_IMP ,DR_IMP,1      ,W_DDL  ,AC     ,
c     6                  ACR   ,A     ,AR     ,R2    ,NDEB0   )
c          END IF
c         END IF           
c
         IF (NBINTC>0) THEN
          IF (ISMDISP>0) THEN
          CALL IMP_DTKIN(
     1       IPARI ,INTBUF_TAB       ,X_A     ,V       ,
     2       VR    ,ITAB   ,D_IMP   ,DR_IMP  ,NBINTC  ,
     3       INTLIST,ITASK  ,NEWFRONT,ISENDTO ,IRECVFROM,
     4       IDDL  ,NDOF   ,IKC     ,TMP     ,MS      ,
     5       NSENSOR,SENSOR_TAB,MAXDGAP)
          ELSE
          CALL IMP_DTKIN(
     1       IPARI ,INTBUF_TAB      ,X       ,V       ,
     2       VR    ,ITAB   ,D_IMP   ,DR_IMP  ,NBINTC  ,
     3       INTLIST,ITASK  ,NEWFRONT,ISENDTO ,IRECVFROM,
     4       IDDL  ,NDOF   ,IKC     ,TMP     ,MS      ,
     5       NSENSOR,SENSOR_TAB,MAXDGAP)
          IF(NFXV_G/=0.AND.TMP<ONE)
     .    CALL FV_IMP(IBFV  ,NPC    ,TF     ,VEL   ,SENSOR_TAB,
     1                D_IMP  ,DR_IMP ,IKC   ,IDDL  ,NSENSOR   ,
     2                SKEW  ,IFRAME ,XFRAME ,V     ,VR    ,
     3                X     ,DIRUL  ,NDOF   ,A     ,AR    )
          END IF !(ISMDISP>0) THEN
         END IF
C
C---------------------------------
citask0        END IF !(ITASK == 0) THEN
C---------------------------------
 300    CONTINUE
C---------------------------------
citask0        IF (ITASK == 0) THEN
C---------------------------------
          IF (ISMDISP>0) THEN
           CALL CP_REAL_HP(NNDL,X_C,X_A)
          ELSE
           CALL CP_REAL_HP(NNDL,X_C,X) 
          END IF
          CALL CP_IMPBUF(2      ,ELBUF   ,ELBUF_C ,BUFMAT  ,BUFMAT_C  ,
     .                   FSAV   ,VOLMON  ,PARTSAV ,INTBUF_TAB       ,
     .                   INTBUF_TAB_C ,IPARI   ,ISLEN7 ,IRLEN7   ,
     .                   ISLEN11,IRLEN11,ISLEN17 ,IRLEN17,IRLEN7T  ,
     .                   ISLEN7T,IRLEN20,ISLEN20 ,IRLEN20T,ISLEN20T,
     .         IRLEN20E,ISLEN20E,NEWFRONT,ELBUF_TAB,ELBUF_IMP,          
     .         IPARG   )          

          IF (NCYCLE == 1 .AND. ISTOP == 0 .AND.ISOLV == 7) THEN
           IF (IT == 1 .AND. I_IMP(5) == 0 ) THEN
                 WRITE (IOUT, *)
     .     "    **PCG SOLVER HAS BEEN SELECTED FIRSTLY FOR THIS RUN**"
                 WRITE (ISTDO, *)
     .     "    **PCG SOLVER HAS BEEN SELECTED FIRSTLY FOR THIS RUN**"
           END IF
          END IF

         IF (ISTOP>0) THEN
          IF (ISTOP == 3 .AND.ISOLV == 7) THEN

             ISOLV = 3
             ISETK = 1
             IKPAT = 0
                 I_IMP(11)=1
                 ISTOP = 0
             IPREC = 1
             IF (NSPMD > 1 ) THEN
              IF (IMUMPSD == 0) IMUMPSD = 1
              IF (IMUMPSV == 0) IMUMPSV = 1
             END IF
            IF (NCYCLE == 1 ) THEN
             IF (ISPMD  == 0) THEN
                  WRITE (IOUT, *)
     .         "    **DIRECT SOLVER HAS BEEN SELECTED FOR THIS RUN**"
                 WRITE (ISTDO, *)
     .         "    **DIRECT SOLVER HAS BEEN SELECTED FOR THIS RUN**"
             END IF !(NSPMD  == 0) THEN
            ELSE
             IF (ISPMD  == 0) THEN
                  WRITE (IOUT, *)
     .         "    **PCG SOLVER HAS BEEN CHANGED TO DIRECT SOLVER **"
                 WRITE (ISTDO, *)
     .         "    **PCG SOLVER HAS BEEN CHANGED TO DIRECT SOLVER **"
             END IF !(NSPMD  == 0) THEN
            END IF

          ENDIF
              IMCONV=-2
          CALL IDDL2NOD(NDDL  ,IDDL  ,NDOF  ,IKC   ,INLOC ,
     .                  ISTOP ,NNOD  )
          IF (NNOD>0) THEN
           WRITE(IOUT,1008)ITAB(NNOD)
           WRITE(ISTDO,1008)ITAB(NNOD)
              ENDIF
         ENDIF
             INCONV = MIN(1,IMCONV)
         IF (IMCONV<=-2) THEN
          CALL ZEROR_HP(D_IMP,NUMNOD)
          IF (IRODDL/=0) CALL ZEROR_HP(DR_IMP,NUMNOD)
          R_IMP(6)=R_IMP(4)
          I_IMP(5)=-2
          IF (ISPRB==1.AND.IMCONV==-3.AND.ICONTA==0) THEN
           DO I=1,NDDL
            LB(I) = LB0(I)
           ENDDO
           IMCONV=1
           GOTO 100
          ENDIF
           TT=MAX(ZERO,TT-DT2)
           NCYCLE=NCYCLE-1
               IF (NCYCLE==0) DT1=ZERO
           CALL INT5_DIVERG(IPARI )
          IF (IMCONV==-2.AND.I_IMP(11)/=1) THEN
C-----------change dt------
           CALL IMP_DTN(IT,R_IMP(11),R_IMP(10),R_IMP(24))
C           CALL NUL_ETFAC_A
           CALL ETFAC_INI(IPARG )
           IF (DT_IMP==DT_MIN) THEN
             CALL IMP_STOP(IMCONV)
           ENDIF
          ENDIF
         ENDIF
C
         IF (IMCONV<=-2.OR.IMCONV==0) THEN
          IF (IT==1.AND.ICONTA>I_IMP(6)) THEN
           R02 =R_IMP(17)
               IF (IREFI==1) THEN
            R02 = MIN(R02,TEN*R_IMP(1))
               ELSEIF (IREFI==2) THEN
            R02 = MIN(R02,ONEP2*R_IMP(1))
               ELSEIF (IREFI==3.OR.IREFI==4.OR.IREFI==5) THEN
             R02 = MIN(R02,R_IMP(1))
               ELSEIF (IREFI==-4) THEN
            I_IMP(7) = 1
                IREFI = 4
               END IF
C----Used for gravity case         
               IF (NCYCLE > 1) I_IMP(7) = 1
           R_IMP(1)=MAX(R_IMP(1),R02)
          ENDIF
         ENDIF !IF (IMCONV<=-2.OR.IMCONV==0)
C------------for restart---
         IF (IMCONV>0) THEN
           R_IMP(1) = MAX(R_IMP(1),RF_MIN*RF_MIN)
           R_IMP(1) = MIN(R_IMP(1),RF_MAX*RF_MAX)
         ENDIF
C
         IF (IMCONV==2) DT2=DT2/I_IMP(2)
C---------------------------------
 200     CONTINUE
C    /---------------/
c      CALL MY_BARRIER
C    /---------------/
C---------------------------------
citask0        IF (ITASK == 0) THEN
C---------------------------------
         IF (IMCONV==1.OR.IMCONV==2.OR.IMCONV==3) THEN
          IF(IDYNA>0.AND.NFXVEL/=0) THEN
            CALL FV_FINT0(IBFV  ,NPC    ,TF   ,VEL   ,SENSOR_TAB,
     1                   D_IMP ,DR_IMP,IKC   ,IDDL  ,NSENSOR   ,
     2                   SKEW   ,IFRAME ,XFRAME,A    ,AR    ,
     3                   X      ,NDOF  ,MS   ,IN    ,WEIGHT ,
     4                   RBY    )
          END IF
          IF (IMCONV/=3) CALL INTEGRATOR1_HP(D_IMP ,D     )
              IF (R_IMP(11)<EM10)
     .      CALL PRODUT_UHP0(D_IMP ,DR_IMP,R_IMP(11),WEIGHT)
          CALL IMP_DTN(IT,R_IMP(11),R_IMP(10),R_IMP(24))
          IF ( IQSTAT>0) CALL DIS_CP(NNDL,D_IMP,DR_IMP,0    )
         ENDIF
         IF (INCONV==1 .AND. (ISUB>0.OR.ISECUT>0.OR.IISROT>0
     .      .OR.ISHSUB/=0.OR.IMPOSE_DR/=0 .OR. IDROT==1)
     .      .AND. IRODDL/=0) THEN
           IF (IMCONV/=3) CALL INTEGRATOR1_HP(DR_IMP,DR)
         ENDIF
         IF (ISMDISP>0) THEN
         CALL INTEGRATOR_HP(NDT   ,D_IMP ,DR_IMP,
     1                      X_A   ,V     ,VR    ,A     ,AR    )
         ELSE
C
         CALL INTEGRATOR_HP(NDT   ,D_IMP ,DR_IMP,
     1                      X     ,V     ,VR    ,A     ,AR    )
         ENDIF
C
         IF(IDYNA>0.AND.IMCONV==1)  THEN
            CALL DYNA_WEX(IBCL  ,FORC   ,NPC   ,TF    ,AC    ,
     2                    V     ,X      ,SKEW  ,ACR   ,VR    ,
     3                    SENSOR_TAB,WEIGHT,TFEXT ,IADS_F,
     4                    FSKY  ,IGRV   ,AGRV  ,MS    ,IN    ,
     5                    LGRAV ,ITASK ,NRBYAC,IRBYAC ,
     6                    NPBY  ,RBY   ,IBFV    ,VEL   ,D_IMP  ,
     7                    DR_IMP,IKC   ,IDDL  ,IFRAME,XFRAME  ,
     8                    NDOF  ,H3D_DATA,CPTREAC,FTHREAC,NODREAC,NSENSOR,
     9                    TH_SURF ,FSAVSURF,NSEG_LOADP) 
           CALL DYNA_CPR0(NDDL0  )
         END IF
C----------D_imp taking D_n-1 :exception for case with Gravity----- 
         IF (IMCONV<=-2 .AND.IQSTAT>0 .AND. I_IMP(7) >0) THEN
           CALL DIS_CP(NNDL,D_IMP,DR_IMP,1    )
         END IF
C
         IF (IMCONV == 3 ) INCONV = 0
         IF (IMCONV<=-2) IMCONV=1
         IF (IMCONV==1) I_IMP(1)=I_IMP(1)+IT+1
         IF (IMCONV==1) I_IMP(12)=INCONV
         I_IMP(4)=NDT-1
		 IT_T = I_IMP(1)
C--------
citask0        END IF !(ITASK == 0) THEN
C
       ENDIF !IF (ILINE==1) THEN
C----------------------
      CALL MY_BARRIER
C---------------------       
citask0       IF (ITASK == 0) THEN
        IF (NINT7>0) THEN
          DEALLOCATE(IADI)
          DEALLOCATE(ITOK)
          DEALLOCATE(JDII)
          DEALLOCATE(DIAG_I)
          DEALLOCATE(LT_I)
        ENDIF
C
        IF ((NSREM+NSL)>0) CALL INI_KIC
        IF (ILINTF>0) DEALLOCATE(XI_C)
        IF (INTP_C<0) CALL DEALLOCM
		IF (NINT2>0) DEALLOCATE(IAINT2)

citask0       END IF !(ITASK == 0) THEN
c
 1001 FORMAT(' SYMBOLIC DIM : NDDL =',I8,1X,'NNZ =',I8,1X,'NB_MAX =',I8)
 1002 FORMAT(' FINAL    DIM : NDDL =',I8,1X,'NNZ =',I8,1X,'NB_MAX =',I8)
 1003 FORMAT(/,5X,'--STIFFNESS MATRIX IS REFORMED --')
 1004 FORMAT(3X,'LINE. SOLVER : ISOLV =',I4,2X,'PREC. Meth. =',I4,2X,
     .       'TOL =',E11.4)
 1005 FORMAT(5X,'--STIFFNESS MATRIX WILL BE REFORMED AFTER EACH ',I4,
     .       2X,'ITERATIONS--')
 1006 FORMAT(5X,'--SUPPLEMENTARY CONTACT STIFFNESS MATRIX',
     .          1X, 'IS CREATED--')
 1007 FORMAT(5X,' WITH DIM. : ND   =',I8,1X,'NZ  =',I8) !,1X,'NB_MAX =',I8)
 1008 FORMAT(3X,'**WARNING: STIFFNESS MATRIX IS NOT DEFINITE**'/,
     .       3X,'**LOOK AT NODE: ',I8)
 1009 FORMAT(3X,'**TIMESTEP WILL BE REDUCED TO AVOID DE-ACTIVATION ',
     .          'IN INTERFACE:**',I8)
 1010 FORMAT(/,5X,'--STIFFNESS MATRIX IS REFORMED',1X,
     .       'DUE TO RIGID WALL IMPACT--'/,5X,'WITH IMPACT NUM. =',I8)
 1011 FORMAT(5X,' WITH DIM. : ND   =',I8)
 1012 FORMAT(3X,'**TIMESTEP WILL BE REDUCED DUE TO ',
     .          'DIM.(ND) CHANGE W/AUTOSPC::**',2I8)
       RETURN
      END
C endif MUMPS defined
#endif 

Chd|====================================================================
Chd|  IMP_STOP                      source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_CHECK                     source/implicit/imp_solv.F    
Chd|        IMP_ERRMUMPS                  source/implicit/imp_solv.F    
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|        M36ITER_IMP                   source/materials/mat/mat036/m36iter_imp.F
Chd|        NL_SOLV                       source/implicit/nl_solv.F     
Chd|-- calls ---------------
Chd|        ANCMSG                        source/output/message/message.F
Chd|        ARRET                         source/system/arret.F         
Chd|        MY_FLUSH                      source/system/machine.F       
Chd|        MESSAGE_MOD                   share/message_module/message_mod.F
Chd|====================================================================
      SUBROUTINE IMP_STOP(ISTOP)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE MESSAGE_MOD
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
#include "comlock.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include "units_c.inc"
#include      "task_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      INTEGER
     .  ISTOP,IMG
      CHARACTER*60       MSG(-4:2)
      DATA               MSG
     .  / 'STOPPED DUE TO SOLVER ERROR **',
     .    'STOPPED DUE TO NCYCLE LIMIT **',
     .    'STOPPED DUE TO TIMESTEP LIMIT **',
     .    'STOPPED DUE TO MODELLING DATA **',
     .    'STOPPED DUE TO LOADING DATA **' ,
     .    'STOPPED DUE TO DIVERGENCE **'  ,
     .    'STOP WITH CHECKING **'  /
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      IF (ISPMD==0) THEN
       IMG=ISTOP
       IF (ISTOP>2) IMG=1
         CALL ANCMSG(MSGID=79,ANMODE=ANINFO,
     .               C1=MSG(IMG),I1=ISTOP)
         CALL MY_FLUSH(IOUT)
      ENDIF
      CALL ARRET(2)
C------------------------------------------
      RETURN
      END
C------------------------------------------
Chd|====================================================================
Chd|  IMP_CHECK                     source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        IMP_STOP                      source/implicit/imp_solv.F    
Chd|====================================================================
      SUBROUTINE IMP_CHECK(ITAB  ,NDDL  ,IDDL  ,DIAG_K  ,NDOF  ,
     .                     IKC   ,INLOC ,NDDL0 )
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "units_c.inc"
#include      "impl1_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      INTEGER NDDL,NDDL0,NDOF(*),IDDL(*),IKC(*),INLOC(*),ITAB(*)
      my_real
     .  DIAG_K(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER NLIM,NID,NN,NKC,NFT,II,IDI,ND,ID,ISTOP
      PARAMETER (NLIM=6)
      INTEGER I,J,K,N,INOD(NLIM),IDL(6*NLIM),NFIX(NDDL0)
C------------------------------------------
       NID=0
       DO I=1,NDDL
        IF (DIAG_K(I)<EM10) THEN
          NID=NID+1
          IDL(NID)=I
          IF (NID==6*NLIM) GOTO 100
        ENDIF
       ENDDO
 100   CONTINUE
       IF (NID>0) THEN
c            write(*,*)'nid=',nid
        NKC=0
        DO N = 1,NUMNOD
         I=INLOC(N)
         DO J=1,NDOF(I)
          ND = IDDL(I)+J
          IF (IKC(ND)>0) NKC=NKC+1
          NFIX(ND)=NKC
         ENDDO
        ENDDO
        NN=0
        NFT=1
        DO 400 K = 1,NID
         DO  N = NFT,NUMNOD
          I=INLOC(N)
          IDI=IDDL(I)
          ID=IDI-NFIX(IDI)
C          IF (ID>IDL(K)) GOTO 400
          DO J=1,NDOF(I)
           ND = IDI+J
           ID = ND-NFIX(ND)
           IF (IDL(K)==ID) THEN
            NN=NN+1
            INOD(NN)=ITAB(I)
c            write(*,*)'id,i,n,j=',id,i,n,j
            IF (NN==NLIM) GOTO 200
            NFT=N+1
            GOTO 400
           ENDIF
          ENDDO
         ENDDO
 400    CONTINUE
 200    CONTINUE
        IF (NN>0) THEN
         ISTOP=1
         WRITE(IOUT,*)
     .   ' **ERROR: STIFFNESS MATRIX IS NOT DEFINITE** '
         WRITE(IOUT,*)'--- LOOK AT NODES:---'
         WRITE(IOUT,*)(INOD(I),I=1,NN)
              WRITE(ISTDO,*)
     .   ' **ERROR: STIFFNESS MATRIX IS NOT DEFINITE** '
         WRITE(ISTDO,*)'--- LOOK AT NODES:---'
         WRITE(ISTDO,*)(INOD(I),I=1,NN)
         IF (NRBE2>0.AND.ILINE==0) ISTOP = 0
         IF (ISTOP>0) CALL IMP_STOP(-1)
        ENDIF
       ENDIF
C
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  PR_INFOK                      source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_CHKM                      source/implicit/imp_solv.F    
Chd|        IMP_K_EIG                     stub/imp_k_eig.F              
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        SPMD_INF_G                    source/mpi/implicit/imp_spmd.F
Chd|====================================================================
      SUBROUTINE PR_INFOK(NDDL0,NNZK0,NDDL,NNZK,NNMAX)
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "units_c.inc"
#include      "task_c.inc"
#include      "scr05_c.inc"
#include      "impl1_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      INTEGER NDDL0,NNZK0,NDDL,NNZK,NNMAX
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER NDDLG0,NNZKG0,NDDLG,NNZKG,NNMAXG,NNMAX0
      INTEGER NDDL0P(NSPMD),NNZK0P(NSPMD),NDDLP(NSPMD) ,
     .        NNZKP(NSPMD),NNMAXP(NSPMD),I
C------------------------------------------
       IF (IMACH==3.AND.NSPMD>1) THEN
        NDDLG0 = NDDL0
        NNZKG0 = NNZK0
        NDDLG = NDDL
        NNZKG = NNZK
        NNMAXG = NNMAX
        CALL SPMD_INF_G(
     1   NDDLG0   ,NNZKG0  ,NDDLG    ,NNZKG    ,NNMAXG    ,
     2   NDDL0P   ,NNZK0P  ,NDDLP    ,NNZKP    ,NNMAXP    )
        IF (ISPMD==0) THEN
         IF (IMP_CHK>0) THEN
            WRITE(IOUT,*)
          WRITE(IOUT,*)'  *--------- STIFFNESS MATRIX INFO. ---------*'
            WRITE(IOUT,1001)NDDLG0,NNZKG0,NNMAXG
           WRITE(IOUT,*)
          DO I=1,NSPMD
            WRITE(IOUT,1003)I,NDDL0P(I),NNZK0P(I),NNMAXP(I)
          ENDDO
            WRITE(IOUT,*)
            WRITE(IOUT,1002)NDDLG,NNZKG,NNMAXG
            WRITE(IOUT,*)
          DO I=1,NSPMD
            WRITE(IOUT,1003)I,NDDLP(I),NNZKP(I),NNMAXP(I)
          ENDDO
         ELSE
            WRITE(IOUT,*)
            WRITE(ISTDO,*)
          WRITE(IOUT,*)'  *--------- STIFFNESS MATRIX SETUP ---------*'
          WRITE(ISTDO,*)'  *--------- STIFFNESS MATRIX SETUP ---------*'
            WRITE(IOUT,1001)NDDLG0,NNZKG0,NNMAXG
            WRITE(ISTDO,1001)NDDLG0,NNZKG0,NNMAXG
            WRITE(IOUT,*)
            WRITE(ISTDO,*)
          DO I=1,NSPMD
            WRITE(IOUT,1003)I,NDDL0P(I),NNZK0P(I),NNMAXP(I)
            WRITE(ISTDO,1003)I,NDDL0P(I),NNZK0P(I),NNMAXP(I)
          ENDDO
            WRITE(IOUT,*)
            WRITE(ISTDO,*)
            WRITE(IOUT,1002)NDDLG,NNZKG,NNMAXG
            WRITE(ISTDO,1002)NDDLG,NNZKG,NNMAXG
            WRITE(IOUT,*)
            WRITE(ISTDO,*)
          DO I=1,NSPMD
            WRITE(IOUT,1003)I,NDDLP(I),NNZKP(I),NNMAXP(I)
            WRITE(ISTDO,1003)I,NDDLP(I),NNZKP(I),NNMAXP(I)
          ENDDO
C          IF (L_LIM==0) L_LIM=NDDLG
         ENDIF
        ENDIF
       ELSE
         IF (IMP_CHK>0) THEN
          WRITE(IOUT,*)
          WRITE(IOUT,*)'  *--------- STIFFNESS MATRIX INFO. ---------*'
          WRITE(IOUT,1001)NDDL0,NNZK0,NNMAX
          WRITE(IOUT,1002)NDDL,NNZK,NNMAX
          WRITE(IOUT,*)
         ELSE
            WRITE(IOUT,*)
            WRITE(ISTDO,*)
          WRITE(IOUT,*)'  *--------- STIFFNESS MATRIX SETUP ---------*'
          WRITE(ISTDO,*)'  *--------- STIFFNESS MATRIX SETUP ---------*'
            WRITE(IOUT,1001)NDDL0,NNZK0,NNMAX
            WRITE(ISTDO,1001)NDDL0,NNZK0,NNMAX
           WRITE(IOUT,1002)NDDL,NNZK,NNMAX
           WRITE(ISTDO,1002)NDDL,NNZK,NNMAX
           WRITE(IOUT,*)
           WRITE(ISTDO,*)
         ENDIF
          IF (L_LIM==0) L_LIM=NDDL
       ENDIF
 1001 FORMAT(' SYMBOLIC DIM : ND =',I8,1X,'NZ =',I10,1X,'NB_MAX =',I8)
 1002 FORMAT(' FINAL    DIM : ND =',I8,1X,'NZ =',I10,1X,'NB_MAX =',I8)
 1003 FORMAT(' PROC=',I5,5X,'ND =',I8,1X,'NZ =',I10,1X,'NB_MAX =',I8)
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  K_BAND                        source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_CHKM                      source/implicit/imp_solv.F    
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|        IND_SPA2                      source/implicit/ind_glob_k.F  
Chd|        IND_SPAN                      source/implicit/ind_glob_k.F  
Chd|-- calls ---------------
Chd|====================================================================
      SUBROUTINE K_BAND(NDDL,IADK,JDIK,NDMAX)
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      INTEGER NDDL,IADK(*),JDIK(*),NDMAX
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,JD,ND(NDDL)
C------------------------------------------
       DO I = 1, NDDL
        ND(I) = 1 + IADK(I+1) - IADK(I)
        DO J = IADK(I),IADK(I+1)-1
         JD = JDIK(J)
         ND(JD) = ND(JD) + 1
        ENDDO
       ENDDO
C
       NDMAX = 0
       DO I = 1, NDDL
        NDMAX = MAX(NDMAX,ND(I))
       ENDDO
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  M_LNZ                         source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_CHKM                      source/implicit/imp_solv.F    
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        DIM_SUBNZ                     source/implicit/imp_solv.F    
Chd|        SP_STAT0                      source/implicit/imp_fsa_inv.F 
Chd|====================================================================
      SUBROUTINE M_LNZ(NDDL,IADK,JDIK,NDMAX,NLMAX)
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      INTEGER NDDL,IADK(*),JDIK(*),NDMAX,NLMAX
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,JD,JM(NDMAX+1),NC,NNZ
C------------------------------------------
       DO I=1,NDDL
        CALL SP_STAT0(I  ,IADK  ,JDIK  ,NC    ,JM    )
        CALL DIM_SUBNZ(IADK  ,JDIK  ,NC    ,JM    ,NNZ  )
        NLMAX = MAX(NLMAX,NNZ)
       ENDDO
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  DIM_SUBNZ                     source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        M_LNZ                         source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        INTAB0                        source/implicit/imp_fsa_inv.F 
Chd|====================================================================
      SUBROUTINE DIM_SUBNZ(IADK  ,JDIK  ,NC    ,JM    , NNZA  )
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER  IADK(*)  ,JDIK(*),NC    ,JM(*),NNZA
C     REAL
C-----------------------------------------------
C   External function
C-----------------------------------------------
      INTEGER INTAB0
      EXTERNAL INTAB0
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,K,JJ,N
C--------------------------------------------
      NNZA=0
      DO I=1,NC
       J=JM(I)
        DO K=IADK(J),IADK(J+1)-1
         JJ=JDIK(K)
         N=INTAB0(NC,JM,JJ)
         IF (N>0) NNZA=NNZA+1
        ENDDO
      ENDDO
C
      RETURN
      END
Chd|====================================================================
Chd|  IMP_CHECM                     source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|====================================================================
      SUBROUTINE IMP_CHECM(ITAB  ,NDDL  ,IDDL  ,DIAG_M  ,NDOF  ,
     .                     IKC   ,INLOC ,NDDL0 )
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "units_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      INTEGER NDDL,NDDL0,NDOF(*),IDDL(*),IKC(*),INLOC(*),ITAB(*)
      my_real
     .  DIAG_M(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER NLIM,NID,NN,NKC,NFT,II,IDI,ND,ID
      PARAMETER (NLIM=6)
      INTEGER I,J,K,N,INOD(NLIM),IDL(6*NLIM),NFIX(NDDL0)
C------------------------------------------
       NID=0
       DO I=1,NDDL
        IF (DIAG_M(I)>EP10) THEN
          NID=NID+1
          IDL(NID)=I
          IF (NID==6*NLIM) GOTO 100
        ENDIF
       ENDDO
 100   CONTINUE
       IF (NID>0) THEN
        NKC=0
        DO N = 1,NUMNOD
         I=INLOC(N)
         DO J=1,NDOF(I)
          ND = IDDL(I)+J
          IF (IKC(ND)>0) NKC=NKC+1
          NFIX(ND)=NKC
         ENDDO
        ENDDO
        NN=0
        NFT=1
        DO 400 K = 1,NID
         DO  N = NFT,NUMNOD
          I=INLOC(N)
          IDI=IDDL(I)
          ID=IDI-NFIX(IDI)
          DO J=1,NDOF(I)
           ND = IDI+J
           ID = ND-NFIX(ND)
           IF (IDL(K)==ID) THEN
            NN=NN+1
            INOD(NN)=ITAB(I)
            IF (NN==NLIM) GOTO 200
            NFT=N+1
            GOTO 400
           ENDIF
          ENDDO
         ENDDO
 400    CONTINUE
 200    CONTINUE
        IF (NN>0) THEN
         WRITE(IOUT,*)
     .   ' **WARNING : POSSIBLE NOT DEFINITE STIFFNESS MATRIX ** '
         WRITE(IOUT,*)'--- LOOK AT NODES:---'
         WRITE(IOUT,*)(INOD(I),I=1,NN)
              WRITE(ISTDO,*)
     .   ' **WARNING : POSSIBLE NOT DEFINITE STIFFNESS MATRIX ** '
         WRITE(ISTDO,*)'--- LOOK AT NODES:---'
         WRITE(ISTDO,*)(INOD(I),I=1,NN)
        ENDIF
       ENDIF
C
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  IMP_B2A                       source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|====================================================================
      SUBROUTINE IMP_B2A(F     ,M      ,IDDL   ,NDOF  ,B  )
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER  IDDL(*),NDOF(*)
C     REAL
      my_real
     . F(3,*),M(3,*),B(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,ID
C------------------------------------------
       DO I = 1,NUMNOD
        DO J =1,NDOF(I)
         ID = IDDL(I) + J
         IF (J>3) THEN
          M(J-3,I) = B(ID)
         ELSE
          F(J,I) = B(ID)
         ENDIF
        ENDDO
       ENDDO
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  INI_KIF                       source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        IMP_LINTF                     share/modules/impbufdef_mod.F 
Chd|====================================================================
      SUBROUTINE INI_KIF
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE IMP_LINTF
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
       NDDLIF = 0
       NZIF = 0
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  SAVE_KIF                      source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        CP_INT                        source/implicit/produt_v.F    
Chd|        CP_REAL                       source/implicit/produt_v.F    
Chd|        IMP_LINTF                     share/modules/impbufdef_mod.F 
Chd|====================================================================
      SUBROUTINE SAVE_KIF(NDDL  ,IADK  ,JDIK  ,DIAG_K,LT_K   ,
     1                    ITOK  ,NDDLG)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE IMP_LINTF
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NDDL,IADK(*),JDIK(*),ITOK(*),NDDLG
C     REAL
      my_real
     .  DIAG_K(*),LT_K(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER IADCP(NDDLIF+1),JDICP(NZIF),ITOCP(NDDLIF)
      INTEGER NDDLI0,NZI0,NZK,IERR1,IERR2,ITAG(NDDLG),
     .        I,J,II,NL,NR,ITON(NDDL)
      my_real
     .  DIAG_CP(NDDLIF),LT_CP(NZIF)
C------------------------------------------
       IF (NDDL==0) RETURN
       IF (NDDLIF==0) THEN
        NDDLIF = NDDL
        NZIF =IADK(NDDL+1)-IADK(1)
        IF(ALLOCATED(IADIF)) DEALLOCATE(IADIF)
        IF(ALLOCATED(JDIIF)) DEALLOCATE(JDIIF)
        IF(ALLOCATED(IFTOK)) DEALLOCATE(IFTOK)
        ALLOCATE(IADIF(NDDLIF+1),IFTOK(NDDLIF),JDIIF(NZIF),STAT=IERR1)
        CALL CP_INT((NDDLIF+1),IADK,IADIF)
        CALL CP_INT(NDDLIF,ITOK,IFTOK)
        CALL CP_INT(NZIF,JDIK,JDIIF)
        IF(ALLOCATED(DIAG_IF)) DEALLOCATE(DIAG_IF)
        IF(ALLOCATED(LT_IF)) DEALLOCATE(LT_IF)
        ALLOCATE(DIAG_IF(NDDLIF),LT_IF(NZIF),STAT=IERR2)
        CALL CP_REAL(NDDLIF,DIAG_K,DIAG_IF)
        CALL CP_REAL(NZIF,LT_K,LT_IF)
       ELSE
        CALL CP_INT((NDDLIF+1),IADIF,IADCP)
        CALL CP_INT(NDDLIF,IFTOK,ITOCP)
        CALL CP_REAL(NDDLIF,DIAG_IF,DIAG_CP)
        CALL CP_INT(NZIF,JDIIF,JDICP)
        CALL CP_REAL(NZIF,LT_IF,LT_CP)
        NDDLI0 = NDDLIF
        NZI0 = NZIF
        DO I = 1,NDDLG
         ITAG(I) = 0
        ENDDO
        DO I = 1,NDDLI0
         ITAG(IFTOK(I)) = I
        ENDDO
        DO I = 1,NDDL
         J = ITOK(I)
         IF (ITAG(J)==0) THEN
          NDDLIF = NDDLIF+1
          NZIF = NZIF+IADK(I+1)-IADK(I)
          ITON(I) = NDDLIF
         ELSE
          ITON(I) = ITAG(J)
         ENDIF
        ENDDO
        IF(ALLOCATED(IADIF)) DEALLOCATE(IADIF)
        IF(ALLOCATED(JDIIF)) DEALLOCATE(JDIIF)
        IF(ALLOCATED(IFTOK)) DEALLOCATE(IFTOK)
        ALLOCATE(IADIF(NDDLIF+1),IFTOK(NDDLIF),JDIIF(NZIF),STAT=IERR1)
        IF(ALLOCATED(DIAG_IF)) DEALLOCATE(DIAG_IF)
        IF(ALLOCATED(LT_IF)) DEALLOCATE(LT_IF)
        ALLOCATE(DIAG_IF(NDDLIF),LT_IF(NZIF),STAT=IERR2)
C---------copy old-----
        CALL CP_INT((NDDLI0+1),IADCP,IADIF)
        CALL CP_INT(NDDLI0,ITOCP,IFTOK)
        CALL CP_REAL(NDDLI0,DIAG_CP,DIAG_IF)
        CALL CP_INT(NZI0,JDICP,JDIIF)
        CALL CP_REAL(NZI0,LT_CP,LT_IF)
C---------add [k]-----
        NL = NDDLI0
        NZIF = NZI0
        DO I = 1,NDDL
         J = ITOK(I)
         IF (ITAG(J)==0) THEN
          NL = NL + 1
          NR = IADK(I+1)-IADK(I)
          IFTOK(NL) = J
          DIAG_IF(NL)=DIAG_K(I)
          DO II = IADK(I),IADK(I+1)-1
           NZIF = NZIF + 1
           JDIIF(NZIF) = ITON(JDIK(II))
           LT_IF(NZIF) = LT_K(II)
          ENDDO
          IADIF(NL+1) = NZIF + 1
         ENDIF
        ENDDO
C
        IF (NL/=NDDLIF)
     .    print *,'--MEMERY PROBLEM [K]if--:',NL,NDDLIF
       ENDIF
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  DIAG_KIF                      source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        LIN_SOLV                      source/implicit/lin_solv.F    
Chd|-- calls ---------------
Chd|        IMP_LINTF                     share/modules/impbufdef_mod.F 
Chd|====================================================================
      SUBROUTINE DIAG_KIF(DIAG_K)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE IMP_LINTF
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      my_real
     .  DIAG_K(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,II
C-----------------------------
       RETURN
       DO I=1,NDDLIF
        II = IFTOK(I)
        DIAG_K(II) = DIAG_K(II) +DIAG_IF(I)
       ENDDO
C-----------------------------
      RETURN
      END
Chd|====================================================================
Chd|  MATV_KIF                      source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        MAV_LT2                       source/implicit/produt_v.F    
Chd|        MAV_LTH                       source/implicit/produt_v.F    
Chd|        MAV_LTH0                      source/implicit/produt_v.F    
Chd|        MAV_LTP                       source/implicit/produt_v.F    
Chd|-- calls ---------------
Chd|        IMP_LINTF                     share/modules/impbufdef_mod.F 
Chd|====================================================================
      SUBROUTINE MATV_KIF(V,W)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE IMP_LINTF
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      my_real
     .  W(*), V(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,K,II,KK
      my_real
     .   L_K
C-----------------------------
       RETURN
       DO I=1,NDDLIF
        II = IFTOK(I)
c        W(II) = W(II) +DIAG_IF(I)*V(II)
        DO J =IADIF(I),IADIF(I+1)-1
         K =JDIIF(J)
         KK = IFTOK(K)
         L_K = LT_IF(J)
         W(II) = W(II) + L_K*V(KK)
         W(KK) = W(KK) + L_K*V(II)
        ENDDO
       ENDDO
C-----------------------------
      RETURN
      END
Chd|====================================================================
Chd|  IMP_CPRE                      source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|-- calls ---------------
Chd|        BUF_DIM                       source/implicit/produt_v.F    
Chd|        CP_REAL                       source/implicit/produt_v.F    
Chd|====================================================================
      SUBROUTINE IMP_CPRE(IFLAG,NNDL   ,
     1  ELBUF  ,ELBUF_C,BUFMAT ,FSAV   ,VOLMON  ,BUFMAT_C,X     ,X_C   ,
     2  PARTSAV,R_IMP  )
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "param_c.inc"
#include      "scr11_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER IFLAG,NNDL
C     REAL
      my_real
     .  ELBUF(*) ,ELBUF_C(*),BUFMAT(*) ,FSAV(*),VOLMON(*) ,BUFMAT_C(*),
     .  X(*)    ,X_C(*) ,PARTSAV(*),R_IMP(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER LI1,LI2,LI3,LI4,LI5
C--------------Iflag= 1->copy; 2 ->restore---------------
       CALL BUF_DIM(LI1,LI2,LI3,LI4)
       IF (IFLAG==1) THEN
           CALL CP_REAL(LI1,ELBUF,ELBUF_C)
           CALL CP_REAL(LI2,BUFMAT,BUFMAT_C)
           CALL CP_REAL(LI3,FSAV,BUFMAT_C(LI2+1))
           CALL CP_REAL(LI4,VOLMON,BUFMAT_C(LI2+LI3+1))
           CALL CP_REAL(NNDL,X,X_C)
           CALL CP_REAL(NPSAV*NPART,PARTSAV,R_IMP(16))
           R_IMP(14) = ENCIN
           R_IMP(15) = ENROT
       ELSEIF (IFLAG==2) THEN
          CALL CP_REAL(LI1,ELBUF_C,ELBUF)
          CALL CP_REAL(LI2,BUFMAT_C,BUFMAT)
          CALL CP_REAL(LI3,BUFMAT_C(LI2+1),FSAV)
          CALL CP_REAL(LI4,BUFMAT_C(LI2+LI3+1),VOLMON)
          CALL CP_REAL(NNDL,X_C,X)
          CALL CP_REAL(NPSAV*NPART,R_IMP(16),PARTSAV)
          ENCIN = R_IMP(14)
          ENROT = R_IMP(15)
       ENDIF
C-----------------------------
      RETURN
      END
Chd|====================================================================
Chd|  IMP_CHECK0                    source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_CHKM                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        SPMD_MAX_I                    source/mpi/implicit/imp_spmd.F
Chd|        SPMD_SEND_VR                  source/mpi/implicit/imp_spmd.F
Chd|        SPMD_SUMF_V                   source/mpi/implicit/imp_spmd.F
Chd|        SPMD_SUM_S                    source/mpi/implicit/imp_spmd.F
Chd|====================================================================
      SUBROUTINE IMP_CHECK0(ITAB  ,NDDL  ,IDDL  ,DIAG_K  ,DIAG_M  ,
     .                      NDOF  ,IKC   ,INLOC ,NDDL0   ,NIR     ,
     .                      NDDLI ,ITOK  ,DIAG_I,IWAR    ,IERR    )
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "units_c.inc"
#include      "task_c.inc"
#include      "scr05_c.inc"
#include      "com01_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      INTEGER NDDL,NDDL0,NDOF(*),IDDL(*),IKC(*),INLOC(*),ITAB(*),
     .        NIR,IWAR  ,IERR, NDDLI ,ITOK(*)
      my_real
     .  DIAG_K(*),DIAG_M(*),DIAG_I(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER NLIM,NN,NKC,NFT,II,IDI,ND,ID,NID,NDMAX
      INTEGER I,J,K,N,IDDLM(NUMNOD)
      CHARACTER  DIR(3)
      DATA DIR/'X','Y','Z'/
      my_real
     .  S
      my_real,
     .         DIMENSION(:,:),ALLOCATABLE :: SR
C------------------------------------------
       IF (IMACH/=3.OR.ISPMD==0) THEN
         WRITE(IOUT,*)
         WRITE(IOUT,*)' ** ZERO STIFFNESS CHECKING **'
         WRITE(IOUT,*)
         WRITE(ISTDO,*)' * ZERO STIFFNESS CHECKING '
       ENDIF
       NID=0
       NIR=0
       DO I=1,NDDL
        DIAG_M(I) = DIAG_K(I)
       ENDDO
       DO I=1,NDDLI
          J=ITOK(I)
          DIAG_M(J)=DIAG_M(J)+DIAG_I(I)
       ENDDO
       IF (IMACH==3.AND.NSPMD>1)CALL SPMD_SUMF_V(DIAG_M)
       DO I=1,NDDL
        IF (DIAG_M(I)<EM10) THEN
         IF (DIAG_M(I)<=EM20) NIR =NIR +1
         NID = NID + 1
        ENDIF
       ENDDO
C
       IF (IMACH==3.AND.NSPMD>1) THEN
        S = NID
        CALL SPMD_SUM_S(S)
        NN = INT(S)
        IF (NN>0) THEN
         S = NIR
         CALL SPMD_SUM_S(S)
         NIR = INT(S)
        ENDIF
       ELSE
        NN = NID
       ENDIF
C
       IERR = IERR + NIR
       IWAR = IWAR + NN-NIR
       IF (IMACH/=3.OR.ISPMD==0) WRITE(IOUT,1000)NN
       IF (NID>0) THEN
         NKC=0
         DO N = 1,NUMNOD
          I=INLOC(N)
          IDDLM(I)=IDDL(I)-NKC
          DO J=1,NDOF(I)
           ND = IDDL(I)+J
           IF (IKC(ND)>0) NKC=NKC+1
          ENDDO
         ENDDO
       ENDIF
       IF (IMACH==3.AND.NSPMD>1) THEN
        NDMAX = NID
        CALL SPMD_MAX_I(NDMAX)
        IF (NID>0) THEN
         II = 0
         ALLOCATE(SR(3,NID))
         DO  N = 1,NUMNOD
          I=INLOC(N)
          IDI=IDDLM(I)
          NKC = 0
          DO J=1,NDOF(I)
           ND = IDDL(I)+J
           IF (IKC(ND)==0) THEN
            NKC=NKC+1
            ID = IDI+NKC
            IF (DIAG_M(ID)<EM10) THEN
              II = II + 1
              SR(1,II)=ITAB(I)
              SR(2,II)=J
              SR(3,II)=DIAG_M(ID)
            ENDIF
           ENDIF
          ENDDO
         ENDDO
         CALL SPMD_SEND_VR(
     1      NID       ,3    ,SR       ,NDMAX     ,IOUT     )
         DEALLOCATE(SR)
        ENDIF
       ELSE
C
        IF (NID>0) THEN
         DO  N = 1,NUMNOD
          I=INLOC(N)
          IDI=IDDLM(I)
          NKC = 0
          DO J=1,NDOF(I)
           ND = IDDL(I)+J
           IF (IKC(ND)==0) THEN
            NKC=NKC+1
            ID = IDI+NKC
            IF (DIAG_M(ID)<EM10) THEN
             IF (J<=3) THEN
              WRITE(IOUT,1001)ITAB(I),DIR(J),DIAG_M(ID)
             ELSE
              WRITE(IOUT,1002)ITAB(I),DIR(J-3),DIAG_M(ID)
             ENDIF
            ENDIF
           ENDIF
          ENDDO
         ENDDO
        ENDIF
       ENDIF
C------------------------------------------
      RETURN
 1000 FORMAT(' ND. =',I8,5X,'WITH POSSIBLE FREE STIFFNESS CHECKED',/)
 1001 FORMAT(' NODE NUM. =',I10,5X,'TRA_DIR = ',1A,5X,'VAL.= ',G14.7)
 1002 FORMAT(' NODE NUM. =',I10,5X,'ROT_DIR = ',1A,5X,'VAL.= ',G14.7)
      END
Chd|====================================================================
Chd|  IMP_CHECM0                    source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_CHKM                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        FR_DLFT                       source/mpi/implicit/imp_fri.F 
Chd|        SPMD_MAX_I                    source/mpi/implicit/imp_spmd.F
Chd|        SPMD_SEND_VR                  source/mpi/implicit/imp_spmd.F
Chd|        SPMD_SUM_S                    source/mpi/implicit/imp_spmd.F
Chd|====================================================================
      SUBROUTINE IMP_CHECM0(ITAB  ,NDDL  ,IDDL  ,DIAG_M  ,NDOF  ,
     .                      IKC   ,INLOC ,NDDL0 ,IWAR    ,IERR  )
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "units_c.inc"
#include      "task_c.inc"
#include      "scr05_c.inc"
#include      "com01_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      INTEGER NDDL,NDDL0,NDOF(*),IDDL(*),IKC(*),INLOC(*),ITAB(*),
     .        IDDIV,IWAR,IERR
      my_real
     .  DIAG_M(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER NLIM,NID,NN,NKC,NFT,II,IDI,ND,ID,IW,IR,NDMAX
      INTEGER I,J,K,N,IDDLM(NUMNOD),IDLFT0,IDLFT1
      CHARACTER  DIR(3)
      DATA DIR/'X','Y','Z'/
      my_real
     .  S
      my_real,
     .         DIMENSION(:,:),ALLOCATABLE :: SR
C------------------------------------------
       IF (IMACH/=3.OR.ISPMD==0) THEN
         WRITE(IOUT,*)
         WRITE(IOUT,*)' ** POSITIVE DEFINITE MATRIX CHECKING **'
         WRITE(IOUT,*)
         WRITE(ISTDO,*)' * POSITIVE DEFINITE MATRIX CHECKING '
       ENDIF
       NID=0
       IDLFT0=0
       IR=0
       IF (IMACH==3.AND.NSPMD>1)
     .   CALL FR_DLFT(NDDL,IDLFT0,IDLFT1)
       DO I=1+IDLFT0,NDDL
        IF (DIAG_M(I)<EM12.OR.DIAG_M(I)>EP10) THEN
         IF (DIAG_M(I)<=EM20) IR =IR +1
         NID = NID+ 1
        ENDIF
       ENDDO
C
       IF (IMACH==3.AND.NSPMD>1) THEN
        S = NID
        CALL SPMD_SUM_S(S)
        NN = INT(S)
        IF (NN>0) THEN
         S = IR
         CALL SPMD_SUM_S(S)
         IR = INT(S)
        ENDIF
       ELSE
        NN = NID
       ENDIF
       IERR = IERR + IR
       IWAR = IWAR + NN-IR
       IF (IMACH/=3.OR.ISPMD==0) WRITE(IOUT,1000)NN
       IF (NID>0) THEN
        NKC=0
        DO N = 1,NUMNOD
         I=INLOC(N)
         IDDLM(I)=IDDL(I)-NKC
         DO J=1,NDOF(I)
          ND = IDDL(I)+J
          IF (IKC(ND)>0) NKC=NKC+1
         ENDDO
        ENDDO
       ENDIF
C
       IF (IMACH==3.AND.NSPMD>1) THEN
        NDMAX = NID
        CALL SPMD_MAX_I(NDMAX)
        ALLOCATE(SR(3,NID))
        IF (NID>0) THEN
         II = 0
         DO  N = 1,NUMNOD
          I=INLOC(N)
          IDI=IDDLM(I)
          IF (NDOF(I)>0.AND.IDI>=IDLFT0) THEN
          NKC = 0
          DO J=1,NDOF(I)
           ND = IDDL(I)+J
           IF (IKC(ND)==0) THEN
            NKC=NKC+1
            ID = IDI+NKC
            IF (DIAG_M(ID)<EM12.OR.DIAG_M(ID)>EP10) THEN
              II = II + 1
              SR(1,II)=ITAB(I)
              SR(2,II)=J
              SR(3,II)=DIAG_M(ID)
            ENDIF
           ENDIF
          ENDDO
          ENDIF
         ENDDO
        ENDIF
        CALL SPMD_SEND_VR(
     1        NID       ,3    ,SR       ,NDMAX     ,IOUT     )
        DEALLOCATE(SR)
       ELSE
C
        IF (NID>0) THEN
         DO  N = 1,NUMNOD
          I=INLOC(N)
          IDI=IDDLM(I)
          IF (NDOF(I)>0.AND.IDI>=IDLFT0) THEN
            NKC = 0
          DO J=1,NDOF(I)
           ND = IDDL(I)+J
           IF (IKC(ND)==0) THEN
            NKC=NKC+1
            ID = IDI+NKC
            IF (DIAG_M(ID)<EM12.OR.DIAG_M(ID)>EP10) THEN
             IF (J<=3) THEN
              WRITE(IOUT,1001)ITAB(I),DIR(J),DIAG_M(ID)
             ELSE
              WRITE(IOUT,1002)ITAB(I),DIR(J-3),DIAG_M(ID)
             ENDIF
            ENDIF
           ENDIF
          ENDDO
          ENDIF
         ENDDO
        ENDIF
       ENDIF
C------------------------------------------
      RETURN
 1000 FORMAT(' ND. =',I8,5X,'WITH POSSIBLE FREE CONNECTION CHECKED',/)
 1001 FORMAT(' NODE NUM. =',I10,5X,'TRA_DIR = ',1A,5X,'VAL.= ',G14.7)
 1002 FORMAT(' NODE NUM. =',I10,5X,'ROT_DIR = ',1A,5X,'VAL.= ',G14.7)
 1003 FORMAT(/,' LOOK AT CONNECTIVITY FOR NODE NUM. =',I10)
      END
#if defined(MUMPS5) 
Chd|====================================================================
Chd|  IMP_CHKM                      source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        RESOL                         source/engine/resol.F         
Chd|-- calls ---------------
Chd|        CFIELD_IMP                    source/loads/general/load_centri/cfield_imp.F
Chd|        DIM_INT_K                     source/implicit/ind_glob_k.F  
Chd|        FORCE                         source/loads/general/force.F  
Chd|        FV_IMP                        source/constraints/general/impvel/fv_imp0.F
Chd|        FV_IMP1                       source/constraints/general/impvel/fv_imp0.F
Chd|        FV_RW                         source/constraints/general/impvel/fv_imp0.F
Chd|        GRAVIT_IMP                    source/loads/general/grav/gravit_imp.F
Chd|        IDEL_INT                      source/implicit/ind_glob_k.F  
Chd|        IMP_CHECK0                    source/implicit/imp_solv.F    
Chd|        IMP_CHECM0                    source/implicit/imp_solv.F    
Chd|        IMP_COMPAB                    source/implicit/imp_solv.F    
Chd|        IMP_COMPABP                   source/implicit/imp_solv.F    
Chd|        IMP_DYNAM                     source/implicit/imp_dyna.F    
Chd|        IMP_FR7I                      source/mpi/implicit/imp_fri.F 
Chd|        IMP_FRFV                      source/mpi/implicit/imp_fri.F 
Chd|        IMP_FRI                       source/mpi/implicit/imp_fri.F 
Chd|        IMP_GLOB_KHP                  source/implicit/imp_glob_k.F  
Chd|        IMP_INT_K                     source/implicit/imp_int_k.F   
Chd|        IMP_SETB                      source/implicit/imp_setb.F    
Chd|        IND_INT_K                     source/implicit/ind_glob_k.F  
Chd|        INI_K0H                       source/implicit/imp_solv.F    
Chd|        K_BAND                        source/implicit/imp_solv.F    
Chd|        LIN_SOLV                      source/implicit/lin_solv.F    
Chd|        MY_BARRIER                    source/system/machine.F       
Chd|        M_LNZ                         source/implicit/imp_solv.F    
Chd|        PRODUT_W                      source/implicit/produt_v.F    
Chd|        PR_INFOK                      source/implicit/imp_solv.F    
Chd|        PVP_K                         source/implicit/imp_solv.F    
Chd|        RGWAL0_IMP                    source/constraints/general/rwall/rgwal0.F
Chd|        SPMD_MAX_I                    source/mpi/implicit/imp_spmd.F
Chd|        SPMD_MIN_S                    source/mpi/implicit/imp_spmd.F
Chd|        SPMD_SUMF_A                   source/mpi/implicit/imp_spmd.F
Chd|        STARTIME                      source/system/timer.F         
Chd|        STOPTIME                      source/system/timer.F         
Chd|        UPD_FR_K                      source/mpi/implicit/imp_fri.F 
Chd|        UPD_GLOB_K                    source/implicit/upd_glob_k.F  
Chd|        UPD_RHS                       source/implicit/upd_glob_k.F  
Chd|        WEIGHTDDL                     source/implicit/recudis.F     
Chd|        ZERO1                         source/system/zero.F          
Chd|        ZEROR                         source/system/zero.F          
Chd|        DRAPE_MOD                     share/modules/drape_mod.F     
Chd|        DSGRAPH_MOD                   share/modules/dsgraph_mod.F   
Chd|        ELBUFDEF_MOD                  ../common_source/modules/mat_elem/elbufdef_mod.F
Chd|        H3D_MOD                       share/modules/h3d_mod.F       
Chd|        IMPBUFDEF_MOD                 share/modules/impbufdef_mod.F 
Chd|        IMP_WORKI                     share/modules/impbufdef_mod.F 
Chd|        INTBUFDEF_MOD                 ../common_source/modules/intbufdef_mod.F
Chd|        SENSOR_MOD                    share/modules/sensor_mod.F    
Chd|        STACK_MOD                     share/modules/stack_mod.F     
Chd|        TH_SURF_MOD                   ../common_source/modules/interfaces/th_surf_mod.F
Chd|====================================================================
      SUBROUTINE IMP_CHKM(
     1  ICODE  ,ISKEW  ,ISKWN  ,IPART  ,IXTG   ,IXS    ,IXQ    ,
     2  IXC    ,IXT    ,IXP    ,IXR    ,IXTG1          ,ITAB   ,ITABM1 ,
     3  NPC    ,IBCL   ,IBFV   ,SENSOR_TAB,NNLINK ,LNLINK ,IPARG  ,IGRV   ,
     4  IPARI  ,INTBUF_TAB,NPRW   ,ICONX  ,NPBY   ,LPBY   ,LRIVET ,
     5  NSTRF  ,LJOINT ,ICODT  ,ICODR  ,ISKY   ,ADSKY  ,IADS_F ,
     6  ILINK  ,LLINK  ,WEIGHT         ,ITASK  ,IBVEL  ,LBVEL  ,FBVEL  ,
     7  X      ,D      ,V      ,VR     ,DR     ,THKE   ,DAMP   ,MS     ,
     8  IN     ,PM     ,SKEW   ,GEO    ,EANI   ,BUFMAT ,BUFGEO ,BUFSF  ,
     9  TF     ,FORC   ,VEL    ,FSAV   ,AGRV   ,FR_WAVE,PARTS0 ,
     A  ELBUF  ,RBY    ,RIVET  ,FR_ELEM,IAD_ELEM,NSENSOR,
     B  WA            ,A      ,AR     ,STIFN  ,STIFR  ,PARTSAV,FSKY   ,
     C  FSKYI  ,IFRAME ,XFRAME ,W16    ,IACTIV ,FSKYM  ,IGEO   ,IPM    ,
     D  TFEXT  ,NODFT  ,NODLT  ,NINT7  ,NUM_IMP,NS_IMP ,NE_IMP ,IND_IMP,
c     D  TFEXT  ,NRBYAC ,IRBYAC ,NSC    ,NMC    ,NINT2  ,IINT2  ,NODFT  ,
c     E  NODLT  ,NDDL0  ,IDDL   ,NDOF   ,IKC    ,NNZK0  ,IADK   ,JDIK   ,
c     F  IADM   ,JDIM   ,IKINW  ,D_IMP  ,DR_IMP ,DD     ,DDR    ,DIAG_K ,
c     I  LT_K   ,DIAG_M ,LT_M   ,LB     ,LB0    ,X_C    ,BUFMAT_C,
c     J  NDDL   ,NNZK   ,INLOC  ,LSIZE  ,NINT7  ,NUM_IMP,NS_IMP ,NE_IMP ,
c     K  IND_IMP,NDOFI  ,IDDLI  ,NKUD   ,IKUD   ,BKUD   ,I_IMP  ,R_IMP  ,
     L  IT     ,RWBUF  ,LPRW   ,FR_WALL,NBINTC ,INTLIST,FOPT   ,RWSAV  ,
     M  FSAVD  ,DIRUL  ,LGRAV  ,IRBE3  ,LRBE3  ,FRBE3  ,
     N  FRWL6  ,IRBE2  ,LRBE2  ,ICFIELD,LCFIELD,CFIELD,ELBUF_TAB,WEIGHT_MD,
     O  STACK  ,DIMFB  ,FBSAV6 ,STABSEN,TABSENSOR,DRAPE_SH4N,DRAPE_SH3N,H3D_DATA,
     P  NDDL0  ,NNZK0  ,IMPBUF_TAB,CPTREAC,FTHREAC,NODREAC,DRAPEG,TH_SURF ,
     Q  FSAVSURF,NSEG_LOADP) 
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE DSGRAPH_MOD
      USE IMP_WORKI
      USE ELBUFDEF_MOD  
      USE INTBUFDEF_MOD 
      USE STACK_MOD
      USE H3D_MOD
      USE IMPBUFDEF_MOD
      USE SENSOR_MOD
      USE DRAPE_MOD
      USE TH_SURF_MOD , ONLY : TH_SURF_
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include "dmumps_struc.h"
#include "timeri_c.inc"
#include "impl1_c.inc"
#include "impl2_c.inc"
#include "param_c.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "scr05_c.inc"
#include "units_c.inc"
#include "task_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER ,INTENT(IN) :: NSENSOR
      INTEGER ITASK,ICODE(*), ISKEW(*), ISKWN(LISKN,*),ITABM1(*),
     .   IPART(*),IXS(*),IXQ(NIXQ,*),IXC(NIXC,*), IXT(NIXT,*),
     .   IXP(NIXP,*),IXR(NIXR,*), IXTG(NIXTG,*), IXTG1(4,*),
     .   ITAB(*),NPC(*), IBCL(*), IBFV(*),IPARG(NPARG,*),IPARI(NPARI,*),
     .   NPRW(*), NPBY(NNPBY,*), LPBY(*),IADS_F(*),
     .   LRIVET(*), NSTRF(*), LJOINT(*), ICODT(*), ICODR(*), ILINK(*),
     .   LLINK(*),ISKY(*),ADSKY(*),
     .   NNLINK(10,*),LNLINK(*),IGRV(*),LGRAV(*),
     .   WEIGHT(*),IFRAME(LISKN,*),IBVEL(NBVELP,*),LBVEL(*),
     .   IACTIV(*),IGEO(*),IPM(*),ICONX(*),NODFT  ,NODLT,IT,
     .   ICFIELD(*),LCFIELD(*),WEIGHT_MD(*),
     .   DIMFB,STABSEN,TABSENSOR(*),CPTREAC,NODREAC(*)
      INTEGER LPRW(*), FR_WALL(NSPMD+2,*), FR_ELEM(*),
     .   IAD_ELEM(2,*),NBINTC ,INTLIST(*),DIRUL(*)
C     REAL
      my_real
     .   X(3,*)    ,D(3,*)      ,V(3,*)   ,VR(3,*),DAMP(*),
     .   MS(*)   ,IN(*)   ,PM(NPROPM,*),SKEW(LSKEW,*),GEO(NPROPG,*),
     .   BUFMAT(*) ,TF(*) ,FORC(*)  ,VEL(*),FSAV(NTHVKI,*) ,ELBUF(*) ,
     .   RWBUF(NRWLP,*),RWSAV(*),RBY(NRBY,*),
     .   RIVET(*),WA(*), A(3,*) ,AR(3,*),PARTSAV(*) ,TFEXT,
     .   STIFN(*) ,STIFR(*),FSKY(*),FSKYI(*),DR(3,*),
     .   EANI(*),AGRV(*), THKE(*),FR_WAVE(*),PARTS0(*),BUFGEO(*),
     .   XFRAME(NXFRAME,*),W16(*),FBVEL(*),FSKYM(*),BUFSF(*),
     .   FOPT(6,*),FSAVD(NTHVKI,*),CFIELD(*),FRBE3(*),
     .   FTHREAC(6,*)
      INTEGER  NDDL0,NNZK0,NINT7
      INTEGER  NUM_IMP(*),NS_IMP(*),NE_IMP(*),IND_IMP(*),
     .         IRBE3(*),LRBE3(*),IRBE2(*),LRBE2(*)
      TYPE (DRAPE_) :: DRAPE_SH4N(NUMELC_DRAPE), DRAPE_SH3N(NUMELTG_DRAPE)
      TYPE (DRAPEG_) :: DRAPEG
C     REAL
c      my_real
c     .  DIAG_K(*),LT_K(*),DD(*) ,DDR(*) ,DIAG_M(*),LT_M(*),LB(*),LB0(*),
c     .  D_IMP(3,*),DR_IMP(3,*),X_C(*) ,BUFMAT_C(*) ,
c     .  BKUD(*),R_IMP(*),AC(3,*),ACR(3,*),FRBE3(*)
      DOUBLE PRECISION
     .        FRWL6(*)
      DOUBLE PRECISION
     .        FBSAV6(12,6,DIMFB)
      TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB
      TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
      TYPE (STACK_PLY) :: STACK
      TYPE(H3D_DATABASE) :: H3D_DATA
      TYPE (IMPBUF_STRUCT_) ,TARGET :: IMPBUF_TAB
      TYPE (SENSOR_STR_) ,DIMENSION(NSENSOR) :: SENSOR_TAB
      TYPE (TH_SURF_) , INTENT(IN) :: TH_SURF
      my_real, INTENT(INOUT) :: FSAVSURF(5,NSURF)
      INTEGER, INTENT(INOUT) :: NSEG_LOADP(NSURF)
C----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER  NNMAX,NKMAX,N_IMPN,N_IMPM,LNSS,LNSS2,NDT,NDS,NT_RW
      INTEGER I,J,NTMP,L1,L2,L3,NNDL,INPRINT,ISTOP,LI10,LI11,
     .        LI1,LI2,LI3,LI4,LI5,LI6,LI7,LI8,LI9,LIF,IC,ISETP,
     .        LI12,LNSS3,LI13,LI14,LI15,LNSB2,LNSRB2
C      INTEGER, DIMENSION(:),ALLOCATABLE :: IADI,JDII,ITOK
      INTEGER, DIMENSION(:),ALLOCATABLE :: NSS,ISS,NSS2,ISS2,NSS3,ISS3
      INTEGER, DIMENSION(:),ALLOCATABLE :: NSB2,ISB2,IAINT2
      INTEGER  NNOD,IFDIS,N1,N2,N3
      INTEGER LBAND,NCL_MAX,IRFLAG,IBID
      my_real
     .  TFEXC,TMP,TMP1,TMP2,R2,BFAC,FACI,R02,GAP,RBID,WE_IMP,LAMDA
C      my_real,
C     .         DIMENSION(:),ALLOCATABLE :: DIAG_I,LT_I
      INTEGER, POINTER     :: NDDL,NNZK,NRBYAC,NINT2,NMC,NMC2,NMONV
      INTEGER, DIMENSION(:) ,POINTER     :: IADK,JDIK,IADM,JDIM
      INTEGER, DIMENSION(:) ,POINTER     :: IDDL,NDOF,INLOC,LSIZE,I_IMP,IKC,
     .                                      IRBYAC,NSC,IINT2,NKUD,IMONV,
     .                                      IKINW,W_DDL,IKUD,NDOFI,IDDLI
      my_real, DIMENSION(:) ,POINTER     :: DIAG_K,LT_K,DIAG_M,LT_M,LB,
     .                                      LB0,BKUD,D_IMP,ELBUF_C,BUFMAT_C,
     .                                      DR_IMP,X_C,DD,DDR,X_A,R_IMP
      my_real, DIMENSION(:) ,POINTER     :: FEXT,DG,DGR,DG0,DGR0,BUFIN_C,AC,ACR
      TYPE(PRGRAPH) :: GRAPHE(1)
      TYPE(DMUMPS_STRUC) MUMPS_PAR
C------------------------------
C        Initialisation
C-----------------------------------------------
          NDDL => IMPBUF_TAB%NDDL
          NNZK => IMPBUF_TAB%NNZK
          NRBYAC => IMPBUF_TAB%NRBYAC
          NINT2 => IMPBUF_TAB%NINT2
          NMC => IMPBUF_TAB%NMC
          NMC2 => IMPBUF_TAB%NMC2
          NMONV => IMPBUF_TAB%NMONV
          IADK => IMPBUF_TAB%IADK
          JDIK => IMPBUF_TAB%JDIK
          IDDL => IMPBUF_TAB%IDDL
          NDOF => IMPBUF_TAB%NDOF
          INLOC => IMPBUF_TAB%INLOC
          LSIZE => IMPBUF_TAB%LSIZE
          I_IMP => IMPBUF_TAB%I_IMP
          IRBYAC => IMPBUF_TAB%IRBYAC
          NSC => IMPBUF_TAB%NSC
          IINT2 => IMPBUF_TAB%IINT2
          NKUD => IMPBUF_TAB%NKUD
          IMONV => IMPBUF_TAB%IMONV
          IKINW => IMPBUF_TAB%IKINW
          IKC => IMPBUF_TAB%IKC
          W_DDL => IMPBUF_TAB%W_DDL
          IKUD => IMPBUF_TAB%IKUD
          IADM => IMPBUF_TAB%IADM
          JDIM => IMPBUF_TAB%JDIM
          IDDLI => IMPBUF_TAB%IDDLI
          NDOFI => IMPBUF_TAB%NDOFI
C		  
          DIAG_K  =>IMPBUF_TAB%DIAG_K  
		  LT_K    =>IMPBUF_TAB%LT_K    
		  DIAG_M  =>IMPBUF_TAB%DIAG_M  
		  LT_M    =>IMPBUF_TAB%LT_M    
		  LB      =>IMPBUF_TAB%LB      
          LB0     =>IMPBUF_TAB%LB0      
		  BKUD    =>IMPBUF_TAB%BKUD    
		  D_IMP   =>IMPBUF_TAB%D_IMP   
		  ELBUF_C =>IMPBUF_TAB%ELBUF_C 
		  BUFMAT_C=>IMPBUF_TAB%BUFMAT_C
	      X_C     =>IMPBUF_TAB%X_C     
		  DD      =>IMPBUF_TAB%DD      
		  DDR     =>IMPBUF_TAB%DDR     
		  FEXT  =>IMPBUF_TAB%FEXT  
		  DG    =>IMPBUF_TAB%DG    
		  DGR   =>IMPBUF_TAB%DGR   
		  DG0   =>IMPBUF_TAB%DG0    
		  DGR0  =>IMPBUF_TAB%DGR0   
		  DR_IMP=>IMPBUF_TAB%DR_IMP   
c		  BUFIN_C=>IMPBUF_TAB%BUFIN_C
		  AC=>IMPBUF_TAB%AC
		  ACR=>IMPBUF_TAB%ACR
          R_IMP => IMPBUF_TAB%R_IMP
		  ALLOCATE(IAINT2(NINT2))
         NDDLI=0
         ISTOP=0
         INEGA=0
         NNDL = 3*NUMNOD
         NSREM=0
         NSL=0
         ISETP = 1
         IMP_IW = 0
         IMP_IR = 0
C
         IF (IRREF>0.AND.IMCONV==1.AND.ILINE/=1) THEN
          IRFLAG=IRREF
         ELSE
          IRFLAG=0
         ENDIF
citask0       IF (ITASK == 0) THEN
C
          CALL ZEROR(D_IMP,NUMNOD)
          IF (IRODDL/=0) CALL ZEROR(DR_IMP,NUMNOD)
          CALL ZEROR(AC,NUMNOD)
          IF (IRODDL/=0) CALL ZEROR(ACR,NUMNOD)
C----------------------------------
C       FORCES EXTERNES A=Fext-Fint
C----------------------------------
         NCL_MAX=0
         R_IMP(16)=ZERO
         IF(NCONLD/=0) THEN
          CALL FORCE(IBCL  ,FORC  ,NPC   ,TF  ,AC    ,
     2               V     ,X     ,SKEW  ,ACR ,VR    ,
     3               NSENSOR,SENSOR_TAB,TFEXC,
     4               IADS_F,FSKY  ,FSKY, RBID,H3D_DATA,
     5               CPTREAC,FTHREAC,NODREAC,TH_SURF ,FSAVSURF,
     6               NSEG_LOADP)
          IF (IMACH==3.AND.NSPMD>1) THEN
           DO I=IAD_ELEM(1,1),IAD_ELEM(1,NSPMD+1)-1
            J = FR_ELEM(I)
	        N1 = 3*(J-1)+1
	        N2 = 3*(J-1)+2
	        N3 = 3*(J-1)+3
            TMP = ABS(AC(N1))+ABS(AC(N2))+ABS(AC(N3))
            IF (IRODDL/=0) TMP = TMP +
     .            ABS(ACR(N1))+ABS(ACR(N2))+ABS(ACR(N3))
            IF (TMP>ZERO) NCL_MAX = NCL_MAX + 1
           ENDDO
          ENDIF
         ENDIF
         IF (IMACH==3.AND.NSPMD>1) THEN
          CALL SPMD_MAX_I(NCL_MAX)
          IF (NCL_MAX>0) THEN
           LBAND = IAD_ELEM(1,NSPMD+1)-IAD_ELEM(1,1)
           IF (IRODDL/=0) THEN
            NTMP = 6
           ELSE
            NTMP = 3
           ENDIF
           CALL SPMD_SUMF_A(AC,ACR,IAD_ELEM,FR_ELEM,NTMP,LBAND)
          ENDIF
         ENDIF
         IF(NGRAV/=0) THEN
c          CALL MY_BARRIER
          CALL GRAVIT_IMP(IGRV  ,AGRV  ,NPC   ,TF    ,AC,
     2                    V     ,X     ,SKEW  ,MS,TFEXC,
     3                    NSENSOR,SENSOR_TAB,WEIGHT,
     4                    LGRAV ,ITASK,
     5                    NRBYAC,IRBYAC,NPBY  ,RBY    )
c          CALL MY_BARRIER
         ENDIF
         IF(NLOADC/=0) THEN
          CALL CFIELD_IMP(ICFIELD  ,CFIELD,NPC   ,TF    ,AC,
     2                    V     ,X     ,XFRAME  ,MS,TFEXC,
     3                    NSENSOR,SENSOR_TAB,WEIGHT,IFRAME,
     4                    LCFIELD ,ITASK,
     5                    NRBYAC,IRBYAC,NPBY  ,RBY,ISKWN    )
         ENDIF
C-------------dU_d---------------------------------
         IF(NFXVEL/=0.AND.IMCONV==1) THEN
          CALL FV_IMP(IBFV  ,NPC    ,TF     ,VEL   ,SENSOR_TAB,
     1                D_IMP ,DR_IMP ,IKC    ,IDDL  ,NSENSOR   ,
     2                SKEW  ,IFRAME ,XFRAME ,V     ,VR    ,
     3                X     ,DIRUL  ,NDOF   ,A     ,VR    )
         ENDIF
C-------------U_d--> rigid wall-------------------------------
        NT_RW=0
        NRWDONE = 0
        IF (NRWALL>0) THEN
         CALL RGWAL0_IMP(
     1     X           ,D_IMP    ,V      ,RWBUF   ,LPRW    ,
     2     NPRW        ,MS       ,FSAV(1,NINTER+1),FR_WALL ,
     3     FOPT        ,RWSAV    ,WEIGHT ,FSAVD(1,NINTER+1),
     4     NT_RW       ,IDDL     ,IKC    ,IMCONV,NDOF,FRWL6,
     5     WEIGHT_MD   ,DIMFB    , FBSAV6,STABSEN,TABSENSOR)
         IF(NT_RW>0) CALL FV_RW(IDDL   ,IKC   ,NDOF  ,D_IMP  ,V )
        ENDIF
        IFDIS=NT_RW+NFXVEL
        IF(IFDIS>0.AND.IMCONV==1) THEN
          IF(NT_RW>0) THEN
           DO I=1,NDDL0
            IF (IKC(I)==3) IKC(I)=4
            IF (IKC(I)==10) IKC(I)=11
           ENDDO
          ENDIF
        ENDIF
        NTMP = NT_RW
        IF (IMACH==3.AND.NSPMD>1) CALL SPMD_MAX_I(NTMP)
        IF(NTMP>0) THEN
          IF(IMACH/=3.OR.ISPMD==0) THEN
           WRITE(IOUT,*)'  *--------- RIGID WALL IMPACT---------*'
          ENDIF
        ENDIF
C----------------------------------
C----------------------------------
         CALL IMP_SETB(AC    ,ACR     ,IDDL   ,NDOF  ,LB    )
C----------------------------------
C  CHECKING
C----------------------------------
          IF (ISPMD==0) THEN
           WRITE(ISTDO,*)
           WRITE(ISTDO,*)' ** BEGIN IMPLICIT MODEL CHECKING **'
           WRITE(IOUT,*)
           WRITE(IOUT,*)' ** BEGIN IMPLICIT MODEL CHECKING **'
           WRITE(IOUT,*)
          ENDIF
        IF (NSPMD>1) THEN
         CALL IMP_COMPABP(
     1    ICODT     ,ICODR     ,ISKEW     ,IBFV      ,NPC       ,
     2    TF        ,VEL       ,NSENSOR   ,SENSOR_TAB,XFRAME    ,
     3    RBY       ,X         ,SKEW      ,LPBY      ,NPBY      ,
     4    ITAB      ,NRBYAC    ,IRBYAC    ,NINT2     ,IINT2     ,
     5    IPARI     ,INTBUF_TAB,NT_RW     ,NDDL      ,
     6    NDOF      ,IKC       ,INLOC     ,IDDL      ,NDDL0     ,
     7    IMP_IW    ,IMP_IR    )
        ELSE
         CALL IMP_COMPAB(
     1    ICODT     ,ICODR     ,ISKEW     ,IBFV      ,NPC       ,
     2    TF        ,VEL       ,NSENSOR   ,SENSOR_TAB,XFRAME    ,
     3    RBY       ,X         ,SKEW      ,LPBY      ,NPBY      ,
     4    ITAB      ,NRBYAC    ,IRBYAC    ,NINT2     ,IINT2     ,
     5    IPARI     ,INTBUF_TAB,NT_RW     ,NDDL      ,
     6    NDOF      ,IKC       ,INLOC     ,IDDL      ,NDDL0     ,
     7    IMP_IW    ,IMP_IR    )
        ENDIF

citask0       END IF !(ITASK == 0) THEN
C----------------------------------
C       MATRICE DE RIGIDITE
C----------------------------------
        IF (ISETK==1) THEN
         IF (IMACH/=3.OR.ISPMD==0) THEN
          WRITE(ISTDO,*)' * FINIT ELEMENT CHECKING '
          WRITE(IOUT,*)' ** FINIT ELEMENT CHECKING **'
          WRITE(IOUT,*)
         ENDIF
          IF (IMON>0 .AND. ITASK ==0) CALL STARTIME(31,1)
          NDDL = NDDL0
          NNZK = NNZK0
          NNMAX=LSIZE(9)
          NKMAX=LSIZE(10)
          NMC2=LSIZE(11)
c        IF (ITASK == 0) THEN
          CALL ZERO1(DIAG_K,NDDL)
          CALL ZERO1(LT_K,NNZK)
c        END IF
          L1 = 1+NIXS*NUMELS
          L2 = L1+6*NUMELS10
          L3 = L2+12*NUMELS20
          LI1 =1
          LI2 = LI1+LSIZE(4)
          LI3 = LI2+LSIZE(5)
          LI4 = LI3+LSIZE(1)
          LI5 = LI4+LSIZE(3)
          LI6 = LI5+LSIZE(7)
          LI7 = LI6+LSIZE(2)
          LI8 = LI7+LSIZE(6)
          LI9 = LI8+NINT2
          LI10 = LI9+LSIZE(8)
          LI11 = LI10+(LSIZE(8)-LCOKM)*LSIZE(9)
          LI12 = LI11+LCOKM*LSIZE(10)
          LI13 = LI12+4*LSIZE(11)
          LI14 = LI13+LSIZE(14)
          LI15 = LI14+LSIZE(15)
          LIF = LI15+LSIZE(16)
C    /---------------/
c      CALL MY_BARRIER
C    /---------------/
         CALL IMP_GLOB_KHP(
     1    PM        ,GEO       ,IPM       ,IGEO      ,ELBUF     ,
     2    IXS       ,IXQ       ,IXC       ,IXT       ,IXP       ,
     3    IXR       ,IXTG      ,IXTG1     ,IXS(L1)   ,
     4    IXS(L2)   ,IXS(L3)   ,IPARG     ,TF        ,NPC       ,
     5    FR_WAVE   ,W16       ,BUFMAT    ,THKE      ,BUFGEO    ,
     6    RBY       ,SKEW      ,X         ,
     7    WA        ,IDDL      ,NDOF      ,DIAG_K    ,LT_K      ,
     8    IADK      ,JDIK      ,IKG       ,IBID      ,ITASK     ,
     9    ELBUF_TAB ,STACK     ,DRAPE_SH4N, DRAPE_SH3N   ,DRAPEG   )
         NDDL_L = NDDL
C    /---------------/
c      CALL MY_BARRIER
C    /---------------/
citask0         IF (ITASK == 0) THEN
C------ 1er VP: for dt check
         IF (IMPDEB>0.AND.NDDL<1000) THEN
          CALL PVP_K(NDDL,IADK,JDIK,IDDL ,INLOC,
     .               NDOF,ITAB,DIAG_K,LT_K ,LAMDA, J , MS  )
          tmp = TWO*sqrt(ONE/LAMDA)
          write(iout,*) 'critical DT =',tmp
         END IF
          IF (IDYNA>0.OR.IQSTAT>0)
     .    CALL IMP_DYNAM(NODFT  ,NODLT   ,IDDL   ,NDOF   ,DIAG_K ,
     .                   MS     ,IN      ,HHT_A  ,WEIGHT ,IADK   ,
     .                   LT_K   )
          CALL UPD_GLOB_K(
     1    ICODT     ,ICODR     ,ISKEW     ,IBFV      ,NPC       ,
     2    TF        ,VEL       ,XFRAME    ,
     3    RBY       ,X         ,SKEW      ,LPBY      ,NPBY      ,
     4    ITAB      ,WEIGHT    ,MS        ,IN        ,NRBYAC    ,
     5    IRBYAC    ,NSC       ,IKINW(LI1),NMC       ,IKINW(LI2),
     6    IKINW(LI3),IKINW(LI4),NINT2     ,IINT2     ,IKINW(LI8),
     7    IKINW(LI5),IKINW(LI6),IKINW(LI7),IPARI     ,INTBUF_TAB,
     8    NDDL      ,NNZK      ,IADK      ,JDIK      ,
     9    DIAG_K    ,LT_K      ,NDOF      ,IDDL      ,IKC       ,
     A    D_IMP     ,LB        ,NKUD      ,IKUD      ,BKUD      ,
     B    NMC2      ,IKINW(LI12),NT_RW    ,DR_IMP    ,DIRUL     ,
     C    IRBE3     ,LRBE3     ,FRBE3     ,IKINW(LI13),IRBE2    ,
     D    LRBE2     ,IKINW(LI14),IKINW(LI15))
C
         IF (IMACH==3.AND.NSPMD>1) THEN
          CALL UPD_FR_K(
     1    IADK     ,JDIK     ,NDOF      ,IKC      ,IDDL     ,
     2    INLOC    ,FR_ELEM  ,IAD_ELEM  ,NDDL     )
C
          CALL WEIGHTDDL(IDDL  ,NDOF  ,IKC  ,WEIGHT ,W_DDL  ,INLOC )
         ENDIF
C
         CALL PR_INFOK(NDDL0,NNZK0,NDDL,NNZK,MAX(NNMAX,NKMAX))
C
          IF (IPREC>4.AND.NKMAX>200) THEN
           CALL K_BAND(NDDL,IADK,JDIK,IBID)
                MAXB = MIN(MAXB,IBID)
C
           IF (MAXB>10000) THEN
            CALL M_LNZ(NDDL,IADK,JDIK,MAXB,MAX_L)
           ENDIF
C
          ENDIF

          CALL INI_K0H(NDDL,NNZK,NNZK,IADK,JDIK)
          IF (IMON>0) CALL STOPTIME(31,1)
citask0        END IF !(ITASK == 0) THEN
        ENDIF

citask0        IF (ITASK == 0) THEN
C----------------------------------
C       MATRICE DE RIGIDITE D'INTERFACE
C----------------------------------
        GAP=EP20
        IF (NINT7>0) THEN
          L1=LSIZE(1)
          L2=LSIZE(2)
          LNSS2=0
          LNSS=0
          IF (IMON>0) CALL STARTIME(31,1)
          IF (IMP_INT==1) CALL IDEL_INT(
     1    IPARI     ,INTBUF_TAB,NUM_IMP   ,NS_IMP    ,NE_IMP    ,
     2    IND_IMP   ,NDOF      ,NINT7     )
          CALL DIM_INT_K(
     1    IPARI     ,INTBUF_TAB,NUM_IMP   ,NS_IMP    ,NE_IMP    ,
     2    NPBY      ,LPBY      ,ITAB      ,NRBYAC    ,IRBYAC    ,
     3    LNSS      ,NINT2     ,IINT2     ,IAINT2    ,LNSS2     ,
     4    NDDLI     ,NNZI      ,IDDLI     ,NDOFI     ,N_IMPN    ,
     5    N_IMPM    ,NNMAX     ,NKMAX     ,NDOF      ,NSREM     ,
     6    IRBE3     ,LRBE3     ,LNSS3     ,IRBE2     ,LRBE2     ,
     7    LNSB2     ,LNSRB2    ,IND_IMP   )
           ALLOCATE(IADI(NDDLI+1))
           ALLOCATE(ITOK(NDDLI))
           ALLOCATE(JDII(NNZI))
           ALLOCATE(NSS2(L2),NSS3(NRBE3),NSB2(LNSRB2))
           NSB2=0
           ALLOCATE(ISS2(LNSS2),ISS3(LNSS3),ISB2(LNSB2))
           ALLOCATE(NSS(L1))
           ALLOCATE(ISS(LNSS))
           DO I=1,L1
            NSS(I)=0
           ENDDO
           CALL IND_INT_K(
     1     IPARI     ,INTBUF_TAB,NUM_IMP   ,NS_IMP    ,NE_IMP      ,
     2     NPBY      ,LPBY      ,ITAB      ,NRBYAC    ,IRBYAC      ,
     3     NSS       ,ISS       ,NINT2     ,IINT2     ,NSS2        ,
     4     ISS2      ,NDDLI     ,NNZI      ,IADI      ,JDII        ,
     5     IDDLI     ,NDOFI     ,N_IMPN    ,ITOK      ,IDDL        ,
     6     NNMAX     ,NKMAX     ,N_IMPM    ,NDOF      ,IAINT2      ,
     7     IRBE3     ,LRBE3     ,NSS3      ,ISS3      ,IRBE2       ,
     8     LRBE2     ,NSB2      ,ISB2      ,IND_IMP   )
           ALLOCATE(DIAG_I(NDDLI))
           ALLOCATE(LT_I(NNZI))
           CALL ZERO1(DIAG_I,NDDLI)
           CALL ZERO1(LT_I,NNZI)
           IF (NSREM>0)
     1       CALL IMP_FR7I(IPARI ,INTBUF_TAB  ,NUM_IMP ,NS_IMP ,NSREM ,
     2                     NBINTC,INTLIST)
Ctmp-------A n'est pas modifie ici -------------------
           CALL IMP_INT_K(A     ,V         ,
     1     ICODT     ,ICODR     ,ISKEW     ,IBFV      ,NPC       ,
     2     TF        ,VEL       ,NSENSOR   ,SENSOR_TAB,XFRAME    ,
     3     RBY       ,X         ,SKEW      ,LPBY      ,NPBY      ,
     4     ITAB      ,WEIGHT    ,MS        ,IN        ,NRBYAC    ,
     5     IRBYAC    ,NSS       ,ISS       ,IPARI     ,INTBUF_TAB,
     6     NINT2     ,IINT2     ,IAINT2    ,NSS2      ,
     7     ISS2      ,NDDLI     ,NNZI      ,IADI      ,JDII      ,
     8     DIAG_I    ,LT_I      ,IDDLI     ,NDDL0     ,IADK      ,
     9     JDIK      ,IKC       ,DIAG_K    ,LT_K      ,IDDL      ,
     A     NUM_IMP   ,NS_IMP    ,NE_IMP    ,IND_IMP   ,NDOFI     ,
     B     ITOK      ,D_IMP     ,LB        ,GAP       ,DIRUL     ,
     C     NT_RW     ,RBID      ,IRBE3     ,LRBE3     ,FRBE3     ,
     D     NSS3      ,ISS3      ,IRBE2     ,LRBE2     ,NSB2      ,
     E     ISB2      )
C
           DEALLOCATE(NSS2,NSS3,NSB2)
           DEALLOCATE(ISS2,ISS3,ISB2)
           DEALLOCATE(NSS)
           DEALLOCATE(ISS)
          IF (NSPMD==1.AND.IMCONV>=0.AND.
     .         (LPRINT/=0.OR.NPRINT/=0)) THEN
            WRITE(IOUT,1006)
c            WRITE(ISTDO,1006)
            WRITE(IOUT,1007)NDDLI,NNZI,NNMAX
c            WRITE(ISTDO,1007)NDDLI,NNZI,NNMAX
            WRITE(IOUT,*)
c            WRITE(ISTDO,*)
          ENDIF
         IF (IMON>0) CALL STOPTIME(31,1)
        ENDIF
C----------------------------------
        IF (NFXVEL/=0.AND.IMCONV==1) THEN
          CALL FV_IMP1(NKUD   ,IKUD    ,BKUD    ,LB    )
        ENDIF
C-------------LB,A,AR devient Fext-Fint---------------------
        CALL UPD_RHS(ICODT ,ICODR ,ISKEW ,IBFV    ,XFRAME ,
     1               RBY   ,X     ,SKEW   ,LPBY   ,NPBY   ,
     2               NRBYAC,IRBYAC,NINT2  ,IINT2  ,IPARI  ,
     3               INTBUF_TAB   ,NDOF   ,IDDL   ,IKC    ,
     4               NDDL0 ,LB    ,ISETK  ,INLOC  ,DIRUL  ,
     5               A     ,AR    ,AC     ,ACR    ,NT_RW  ,
     6               IRFLAG,W_DDL ,NDDL   ,R_IMP(1),IDYNA ,
     7               V     ,VR    ,MS     ,IN     ,IRBE3  ,
     8               LRBE3 ,FRBE3 ,WEIGHT ,IRBE2  ,LRBE2  )

        IF (IMACH==3.AND.NSPMD>1) THEN
         IF (NBINTC>0.) THEN
          ICONTA = NDDLI + NSREM
          CALL SPMD_MAX_I(ICONTA)
          IF (ICONTA> 0) THEN
           CALL IMP_FRI(
     1    NUM_IMP   ,NS_IMP    ,NE_IMP    ,IPARI     ,INTBUF_TAB,
     2    NPBY      ,LPBY      ,ITAB      ,NRBYAC    ,
     3    IRBYAC    ,NINT2     ,IINT2     ,IDDL      ,IKC       ,
     4    NDOF      ,INLOC     ,NSREM     ,NSL       ,NBINTC    ,
     5    INTLIST   ,X         ,IBFV      ,DIRUL     ,SKEW      ,
     6    XFRAME    ,ISKEW     ,ICODT     ,A         ,D_IMP     ,
     7    LB        ,IFDIS     ,NDDL      ,DR_IMP    ,IDDLI     ,
     8    IRBE3     ,LRBE3     ,FRBE3     ,IRBE2  ,LRBE2 )
           CALL SPMD_MIN_S(GAP)
           CALL SPMD_MAX_I(IFDIS)
           IF ((NSREM+NSL)>0.AND.IFDIS>0)
     .       CALL IMP_FRFV(
     1    NUM_IMP   ,NS_IMP    ,NE_IMP    ,IPARI     ,INTBUF_TAB,
     2    IDDL      ,IKC       ,NDOF      ,NSREM     ,
     3    NSL       ,D_IMP     ,DD        ,DR_IMP    ,DDR       ,
     4    A         ,AR        ,MS        ,V         ,X         ,
     5    LB        ,NDDL      ,IBFV      ,SKEW      ,XFRAME    ,
     6    IRBE3     ,LRBE3     ,IRBE2     ,LRBE2     ,R_IMP(16) ,
     7    NDDL0     ,W_DDL     )
          ENDIF
         ENDIF
        ENDIF
        IF (GAP<ZERO) THEN
         IMCONV = -2
          IF (IMACH/=3.OR.ISPMD==0) THEN
           WRITE(IOUT,1009)INT(-GAP)
           WRITE(ISTDO,1009)INT(-GAP)
          ENDIF
        ENDIF
C----------------------------------
C       IMPLICIT [K] CHECK
C----------------------------------
           CALL IMP_CHECK0(ITAB  ,NDDL  ,IDDL  ,DIAG_K  ,DIAG_M  ,
     .                     NDOF  ,IKC   ,INLOC ,NDDL0   ,INEGA   ,
     .                     NDDLI ,ITOK  ,DIAG_I,IMP_IW  ,IMP_IR )
          IF (INEGA>0) GOTO 100
          NTMP=0
          CALL PRODUT_W(NDDL,LB,LB,W_DDL,R2)
          IF (R2>ZERO.AND.R2<EP30) THEN
          ELSEIF(IQSTAT>0) THEN
           WRITE(IOUT,*)
           WRITE(IOUT,*)' ** WARNING :IMPLICIT LOADING DATA **'
           IMP_IW = IMP_IW + 1
          ELSE
           WRITE(IOUT,*)
           WRITE(IOUT,*)' ** ERROR :IMPLICIT LOADING DATA **'
           IMP_IR = IMP_IR + 1
          ENDIF

citask0         END IF !(ITASK == 0) THEN
C
C    /---------------/
c      CALL MY_BARRIER
C    /---------------/
         CALL LIN_SOLV(NDDL  ,IDDL  ,NDOF   ,IKC   ,D_IMP ,
     1                 DR_IMP,L_TOL ,NNZK   ,IADK  ,JDIK  ,
     2                 DIAG_K,LT_K   ,NDDLI  ,IADI  ,JDII  ,
     3                 DIAG_I,LT_I   ,ITOK   ,IADM  ,JDIM  ,
     4                 DIAG_M,LT_M   ,LB    ,R_IMP(6),INLOC ,
     5                 FR_ELEM,IAD_ELEM,W_DDL,ITASK ,ISETP  ,
     6                 ISTOP ,A     ,AR     ,V    ,
     7                 MS    ,X     ,IPARI ,INTBUF_TAB   ,
     8                 NUM_IMP,NS_IMP,NE_IMP,NSREM ,NSL  ,
     9                 NTMP  ,GRAPHE, ITAB  ,RBID  ,IBID ,
     A                 IBID  ,NTMP  ,IBID   ,IBID  ,IBID ,
     B                 IBID  ,RBID   ,IBFV  ,SKEW  ,
     C                 XFRAME,MUMPS_PAR,IBID,IBID  ,RBID ,
     D                 IRBE3 ,LRBE3 ,IRBE2  ,LRBE2 )
c       IF (ITASK == 0) THEN
          CALL IMP_CHECM0(ITAB  ,NDDL  ,IDDL  ,DIAG_M  ,NDOF  ,
     .                    IKC   ,INLOC ,NDDL0 ,IMP_IW  ,IMP_IR)
        IF (NINT7>0) THEN
          DEALLOCATE(IADI)
          DEALLOCATE(ITOK)
          DEALLOCATE(JDII)
          DEALLOCATE(DIAG_I)
          DEALLOCATE(LT_I)
        ENDIF
c       END IF !(ITASK == 0) THEN

 100    CONTINUE
C    /---------------/
      CALL MY_BARRIER
C    /---------------/
         IF (ISPMD == 0 .AND. ITASK == 0) THEN
           WRITE(ISTDO,1011)IMP_IR,IMP_IW
          ENDIF

 1001 FORMAT(' SYMBOLIC DIM : NDDL =',I8,1X,'NNZ =',I8,1X,'NB_MAX =',I8)
 1002 FORMAT(' FINAL    DIM : NDDL =',I8,1X,'NNZ =',I8,1X,'NB_MAX =',I8)
 1006 FORMAT(5X,'--SUPPLEMENTARY STIFFNESS MATRIX',
     .       1X, 'DUE TO INTERFACE IS CREATED --')
 1007 FORMAT(5X,' WITH DIM. : ND   =',I8,1X,'NZ  =',I8,1X,'NB_MAX =',I8)
 1009 FORMAT(3X,'**TIMESTEP WILL BE REDUCED TO AVOID DE-ACTIVATION ',
     .          'IN INTERFACE :**',I8)
 1011 FORMAT(/,2X,'** END IMPLICIT MODEL CHECKING **'/,
     .       5X,'TERMINATION WITH '/,I8,' ERRORS '/,I8,' WARNINGS'/
     .       5X,'** DETAILS REPORTED IN LISTING FILE **'/)
       RETURN
      END
Chd|====================================================================
Chd|  IMP_COMPAB                    source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_CHKM                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        INTBUFDEF_MOD                 ../common_source/modules/intbufdef_mod.F
Chd|        SENSOR_MOD                    share/modules/sensor_mod.F    
Chd|====================================================================
      SUBROUTINE IMP_COMPAB(
     1    ICODT     ,ICODR     ,ISKEW     ,IBFV      ,NPC       ,
     2    TF        ,VEL       ,NSENSOR   ,SENSOR_TAB,XFRAME    ,
     3    RBY       ,X         ,SKEW      ,LPBY      ,NPBY      ,
     4    ITAB      ,NRBYAC    ,IRBYAC    ,NINT2     ,IINT2     ,
     5    IPARI     ,INTBUF_TAB,NT_RW     ,NDDL      ,
     6    NDOF      ,IKC       ,INLOC     ,IDDL      ,NDDL0     ,
     7    IWAR      ,IERR      )
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE INTBUFDEF_MOD
      USE SENSOR_MOD
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "tabsiz_c.inc"
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "com08_c.inc"
#include      "param_c.inc"
#include      "dmumps_struc.h"
#include      "sphcom.inc"
#include      "units_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER ,INTENT(IN) :: NSENSOR
      INTEGER NPC(*),IBFV(NIFV,*),
     .        ICODT(*),ICODR(*),ISKEW(*),NINT2 ,IINT2(*),NT_RW
      INTEGER LPBY(*),NPBY(NNPBY,*),ITAB(*),IPARI(NPARI,*),
     .        NRBYAC,IRBYAC(*),NDDL,NDOF(*),
     .        IDDL(*),IKC(*),INLOC(*) ,NDDL0,IERR,IWAR
      my_real RBY(NRBY,*) ,X(3,*) ,SKEW(*)
      my_real TF(*),VEL(LFXVELR,*),XFRAME(NXFRAME,*)
      TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
      TYPE (SENSOR_STR_) ,DIMENSION(NSENSOR) :: SENSOR_TAB
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER NSN,I,J,K,N,M,JI,NS,NN,IRW,ID
      INTEGER NKINE,IKIN(NUMNOD),IOF(NUMNOD)
      INTEGER ISENS,II,IDEB,IT,ICOMP,NTY,IR,IW
      my_real STARTT, STOPT, TS,SS
      CHARACTER*25  MSG_TYPE(2)
      CHARACTER*25  CSP
      DATA MSG_TYPE/ '** WARNING **', '!! ERROR !!'/
C--------implicit imcompability--
        ICOMP = 0
        IT = 1
         WRITE(IOUT,*)
         WRITE(IOUT,*)' ** INCOMBABILITY CHECKING **'
         WRITE(IOUT,*)
         WRITE(ISTDO,*)
         WRITE(ISTDO,*)' * INCOMBABILITY CHECKING '
C-----------
        IF (NLASER>0) THEN
         ICOMP = ICOMP + NLASER
         IWAR = IWAR +1
         WRITE(IOUT,1100)MSG_TYPE(IT),'IMPACT LASER'
        ENDIF
        DO N =1,NINTER
         NTY   =IPARI(7,N)
         IF (NTY==2.OR.NTY==7.OR.NTY==10.OR.NTY==11
     .       .OR.NTY==5.OR.NTY==24) THEN
          IF(NTY==7.AND.IPARI(33,N)/=0)THEN
           ICOMP = ICOMP + IPARI(33,N)
           IWAR = IWAR +1
           WRITE(IOUT,1100)MSG_TYPE(IT),'LAGRANGE MULTIPLIER INTERFACE'
          ENDIF
         ELSEIF (NTY>0) THEN
          IWAR = IWAR +1
          ICOMP = ICOMP + 1
          WRITE(CSP,'(A,I2.2)')'INTERFACE TYPE ',NTY
          WRITE(IOUT,1100)MSG_TYPE(IT),CSP
         ENDIF
        ENDDO
        IF (NRIVET>0) THEN
         ICOMP = ICOMP + NRIVET
         IWAR = IWAR +1
         WRITE(IOUT,1100)MSG_TYPE(IT),'RIVET'
        ENDIF
        IF (NGJOINT>0) THEN
         ICOMP = ICOMP + NGJOINT
         IWAR = IWAR +1
         WRITE(IOUT,1100)MSG_TYPE(IT),'JOINT TYPE SPRINGS'
        ENDIF
        IF (NJOINT>0) THEN
         ICOMP = ICOMP + NJOINT
         IWAR = IWAR +1
         WRITE(IOUT,1100)MSG_TYPE(IT),'CYLINDRIC JOINT'
        ENDIF
        IF (NUMMPC>0) THEN
         ICOMP = ICOMP + NUMMPC
         IWAR = IWAR +1
         WRITE(IOUT,1100)MSG_TYPE(IT),'MULTI-POINT CONSTRAINTS'
        ENDIF
        IF (NLINK>0) THEN
         ICOMP = ICOMP + NLINK
         IWAR = IWAR +1
         WRITE(IOUT,1100)MSG_TYPE(IT),'RIGID LINK'
        ENDIF
        IF (NUMELX>0) THEN
         ICOMP = ICOMP + NUMELX
         IWAR = IWAR +1
         WRITE(IOUT,1100)MSG_TYPE(IT),'MULTI-PURPOSE ELEMENTS'
        ENDIF
        IF (NUMELS16>0) THEN
         ICOMP = ICOMP + NUMELS16
         IWAR = IWAR +1
         WRITE(IOUT,1100)MSG_TYPE(IT),'SOLID 16n. ELEMENTS'
        ENDIF
        IF (NUMELS20>0) THEN
         ICOMP = ICOMP + NUMELS20
         IWAR = IWAR +1
         WRITE(IOUT,1100)MSG_TYPE(IT),'SOLID 20n. ELEMENTS'
        ENDIF
        IF (NUMELTG6>0) THEN
         ICOMP = ICOMP + NUMELTG6
         IWAR = IWAR +1
         WRITE(IOUT,1100)MSG_TYPE(IT),'SHELL S3N6 ELEMENTS'
        ENDIF
        IF (NUMSPH>0) THEN
         ICOMP = ICOMP + NUMSPH
         IWAR = IWAR +1
         WRITE(IOUT,1100)MSG_TYPE(IT),'SPH ELEMENTS'
        ENDIF
C
       IF (ICOMP>0) WRITE(IOUT,1101) ICOMP
C--------IKIN: 1 MAIN node of rb, 2 s.n. of int2--,3 s.n. of rb,
C------------: 4 bcs, 5 imposed Dis. ,6 sn of rwall, 7 ns of joint,8 ns os rlink
      DO N =1,NUMNOD
       IKIN(N)=0
       IF (NDOF(N)>0) THEN
        IOF(N)=2
       ELSE
        IOF(N)=1
       ENDIF
      ENDDO
C----- MAIN of rigid body first------
      IR =0
      DO I=1,NRBYAC
       N=IRBYAC(I)
       M=NPBY(1,N)
       IF (IKIN(M)==0) THEN
        IKIN(M)=1
       ELSE
        WRITE(IOUT,1001)MSG_TYPE(2),ITAB(M)
        IR = IR + 1
       ENDIF
      ENDDO
       IERR = IERR +IR
C------interface 2--------------
      IW =0
      IR =0
      DO I=1,NINT2
       N=IINT2(I)
       NSN = IPARI(5,N)
       DO J=1,NSN
        NS=INTBUF_TAB(N)%NSV(J)
        IF (IKIN(NS)==0) THEN
         IKIN(NS)=2
        ELSEIF(IKIN(NS)==1) THEN
         WRITE(IOUT,1002)MSG_TYPE(1),ITAB(NS)
         IW =IW + 1
        ELSEIF(IKIN(NS)==2) THEN
         WRITE(IOUT,1003)MSG_TYPE(2),ITAB(NS)
         IR =IR + 1
        ENDIF
       ENDDO
      ENDDO
C----- rigid body ------
      DO I=1,NRBYAC
       N=IRBYAC(I)
       K=IRBYAC(I+NRBYKIN)
       M=NPBY(1,N)
       NSN  =NPBY(2,N)
       DO J=1,NSN
        NS=LPBY(K+J)
         IF (IKIN(NS)==0) THEN
          IKIN(NS)=3
         ELSEIF(IKIN(NS)==1) THEN
          WRITE(IOUT,1004)MSG_TYPE(1),ITAB(NS)
          IW =IW + 1
         ELSEIF(IKIN(NS)==2) THEN
          IT = MIN(IOF(NS),2)
          WRITE(IOUT,1005)MSG_TYPE(IT),ITAB(NS)
          IF (IT==1) THEN
           IW =IW + 1
          ELSEIF (IT==2) THEN
           IR =IR + 1
          ENDIF
         ELSEIF(IKIN(NS)==3) THEN
          IT = MIN(IOF(NS),2)
          WRITE(IOUT,1006)MSG_TYPE(IT),ITAB(NS)
          IF (IT==1) THEN
           IW =IW + 1
          ELSEIF (IT==2) THEN
           IR =IR + 1
          ENDIF
         ENDIF
       ENDDO
      ENDDO
C--------bcs---------
      IF (IRODDL==0) THEN
       DO N = 1,NUMNOD
        IF (ICODT(N) > 0) THEN
         IF (IKIN(N)==0) THEN
          IKIN(N)=4
         ELSEIF(IKIN(N)==2) THEN
          IT = MIN(IOF(N),2)
          WRITE(IOUT,1007)MSG_TYPE(IT),ITAB(N)
          IF (IT==1) THEN
           IW =IW + 1
          ELSEIF (IT==2) THEN
           IR =IR + 1
          ENDIF
         ELSEIF(IKIN(N)==3) THEN
          IT = MIN(IOF(N),2)
          WRITE(IOUT,1008)MSG_TYPE(IT),ITAB(N)
          IF (IT==1) THEN
           IW =IW + 1
          ELSEIF (IT==2) THEN
           IR =IR + 1
          ENDIF
         ENDIF
        ENDIF
       ENDDO
      ELSE
       DO N = 1,NUMNOD
        IF ((ICODT(N)+ICODR(N))>0 ) THEN
         IF (IKIN(N)==0) THEN
          IKIN(N)=4
         ELSEIF(IKIN(N)==2) THEN
          IT = MIN(IOF(N),2)
          WRITE(IOUT,1007)MSG_TYPE(IT),ITAB(N)
          IF (IT==1) THEN
           IW =IW + 1
          ELSEIF (IT==2) THEN
           IR =IR + 1
          ENDIF
         ELSEIF(IKIN(N)==3) THEN
          IT = MIN(IOF(N),2)
          WRITE(IOUT,1008)MSG_TYPE(IT),ITAB(N)
          IF (IT==1) THEN
           IW =IW + 1
          ELSEIF (IT==2) THEN
           IR =IR + 1
          ENDIF
         ENDIF
        ENDIF
       ENDDO
      ENDIF
C--------fxv---------
      DO NN=1,NFXVEL,NVSIZ
        IF (IBFV(8,NN)==1) GOTO 100
        IF (NSENSOR>0) THEN
          DO 10 II = 1, MIN(NFXVEL-IDEB,NVSIZ)
            N = II+IDEB
            STARTT = VEL(2,N)
            STOPT  = VEL(3,N)
            IF(TT<STARTT)GOTO 10
            IF(TT>STOPT) GOTO 10
            I=IABS(IBFV(1,N))
            ISENS=0
            DO K=1,NSENSOR
              IF(IBFV(4,N)==SENSOR_TAB(K)%SENS_ID) ISENS=K
            ENDDO
            IF(ISENS==0)THEN
              TS=TT
            ELSE
              TS = TT-SENSOR_TAB(ISENS)%TSTART
              IF(TS<ZERO)GOTO 10
            ENDIF
            IF (IKIN(I)==0) THEN
             IKIN(I)=5
            ELSEIF(IKIN(I)==2) THEN
             WRITE(IOUT,1009)MSG_TYPE(2),ITAB(I)
             IR =IR + 1
            ELSEIF(IKIN(I)==3) THEN
             WRITE(IOUT,1010)MSG_TYPE(2),ITAB(I)
             IR =IR + 1
            ELSEIF(IKIN(I)==4) THEN
             WRITE(IOUT,1011)MSG_TYPE(2),ITAB(I)
             IR =IR + 1
            ENDIF
 10       CONTINUE
        ELSE
          DO 20 II = 1, MIN(NFXVEL-IDEB,NVSIZ)
            N = II+IDEB
            STARTT = VEL(2,N)
            STOPT  = VEL(3,N)
            IF(TT<STARTT)GOTO 20
            IF(TT>STOPT) GOTO 20
            I=IABS(IBFV(1,N))
            IF (IKIN(I)==0) THEN
             IKIN(I)=5
            ELSEIF(IKIN(I)==2) THEN
             WRITE(IOUT,1009)MSG_TYPE(2),ITAB(I)
             IR =IR + 1
            ELSEIF(IKIN(I)==3) THEN
             WRITE(IOUT,1010)MSG_TYPE(2),ITAB(I)
             IR =IR + 1
            ELSEIF(IKIN(I)==4) THEN
             WRITE(IOUT,1011)MSG_TYPE(2),ITAB(I)
             IR =IR + 1
            ENDIF
 20       CONTINUE
        ENDIF
C
        IDEB = IDEB + MIN(NFXVEL-IDEB,NVSIZ)
 100    CONTINUE
      ENDDO
C--------rwall---------
      IF (NT_RW>0) THEN
       DO I = 1,NUMNOD
        K = MIN(3,NDOF(I))
        IRW = 0
        DO J =1,K
         ID = IDDL(I) + J
         IF (IKC(ID)==4.OR.IKC(ID)==11) IRW = 1
        ENDDO
        IF (IRW>0) THEN
         IF (IKIN(I)==0) THEN
          IKIN(I)=6
         ELSEIF(IKIN(I)==2) THEN
          WRITE(IOUT,1012)MSG_TYPE(2),ITAB(I)
             IR =IR + 1
         ELSEIF(IKIN(I)==3) THEN
          WRITE(IOUT,1013)MSG_TYPE(2),ITAB(I)
             IR =IR + 1
         ELSEIF(IKIN(I)==4) THEN
          WRITE(IOUT,1014)MSG_TYPE(2),ITAB(I)
             IR =IR + 1
         ELSEIF(IKIN(I)==5) THEN
          WRITE(IOUT,1015)MSG_TYPE(1),ITAB(I)
             IW =IW + 1
         ENDIF
        ENDIF
       ENDDO
      ENDIF
       IERR = IERR +IR
       IWAR = IWAR +IW
       RETURN
 1001 FORMAT(A,' NODE USED FOR DIFF. RBODY MAIN=',I8)
 1002 FORMAT(A,' INCOMPABILITY NODE BETWEEN ',/
     .       'RBODY MAIN AND INTERF. TYPE2 SECONDARY =',I8)
 1003 FORMAT(A,' INCOMPABILITY NODE BETWEEN ',/
     .       'INTERF. TYPE2 SECONDARY AND INTERF. TYPE2 SECONDARY=',I8)
 1004 FORMAT(A,' INCOMPABILITY NODE BETWEEN ',/
     .       ' RBODY MAIN AND RBODY SECONDARY=',I8)
 1005 FORMAT(A,' INCOMPABILITY NODE BETWEEN ',/
     .       ' INTERF. TYPE2 SECONDARY AND RBODY SECONDARY=',I8)
 1006 FORMAT(A,' INCOMPABILITY NODE BETWEEN ',/
     .       ' RBODY SECONDARY AND RBODY SECONDARY=',I8)
 1007 FORMAT(A,' INCOMPABILITY NODE BETWEEN ',/
     .       ' BOUNDARY CONDITIONS AND INTERF. TYPE2 SECONDARY=',I8)
 1008 FORMAT(A,' INCOMPABILITY NODE BETWEEN ',/
     .       ' BOUNDARY CONDITIONS AND RBODY SECONDARY=',I8)
 1009 FORMAT(A,' INCOMPABILITY NODE BETWEEN ',/
     .       ' IMPOSED DISP. AND INTERF. TYPE2 SECONDARY=',I8)
 1010 FORMAT(A,' INCOMPABILITY NODE BETWEEN ',/
     .       ' IMPOSED DISP. AND RBODY SECONDARY=',I8)
 1011 FORMAT(A,' INCOMPABILITY NODE BETWEEN ',/
     .       ' IMPOSED DISP. AND BOUNDARY CONDITIONS=',I8)
 1012 FORMAT(A,' INCOMPABILITY NODE BETWEEN ',/
     .       ' RWALL CONTACT AND INTERF. TYPE2 SECONDARY=',I8)
 1013 FORMAT(A,' INCOMPABILITY NODE BETWEEN ',/
     .       ' RWALL CONTACT AND RBODY SECONDARY=',I8)
 1014 FORMAT(A,' INCOMPABILITY NODE BETWEEN ',/
     .       ' RWALL CONTACT AND BOUNDARY CONDITIONS=',I8)
 1015 FORMAT(A,' INCOMPABILITY NODE BETWEEN ',/
     .       ' RWALL CONTACT AND IMPOSED DISP.=',I8)
 1100 FORMAT(A,' IMPLICIT IS INCOMPABLE WITH :',A/)
 1101 FORMAT(/'**STIFFNESS WILL BE IGNORED WITH',1X,I8,
     .        ' INCOMPABLE OPTIONS**'/)
      END
Chd|====================================================================
Chd|  IMP_COMPABP                   source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_CHKM                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        SPMD_MAX_I                    source/mpi/implicit/imp_spmd.F
Chd|        SPMD_SEND_VI                  source/mpi/implicit/imp_spmd.F
Chd|        SPMD_SUM_S                    source/mpi/implicit/imp_spmd.F
Chd|        INTBUFDEF_MOD                 ../common_source/modules/intbufdef_mod.F
Chd|        SENSOR_MOD                    share/modules/sensor_mod.F    
Chd|====================================================================
      SUBROUTINE IMP_COMPABP(
     1    ICODT     ,ICODR     ,ISKEW     ,IBFV      ,NPC       ,
     2    TF        ,VEL       ,NSENSOR   ,SENSOR_TAB,XFRAME    ,
     3    RBY       ,X         ,SKEW      ,LPBY      ,NPBY      ,
     4    ITAB      ,NRBYAC    ,IRBYAC    ,NINT2     ,IINT2     ,
     5    IPARI     ,INTBUF_TAB,NT_RW     ,NDDL      ,
     6    NDOF      ,IKC       ,INLOC     ,IDDL      ,NDDL0     ,
     7    IWAR      ,IERR      )
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE INTBUFDEF_MOD
      USE SENSOR_MOD
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "com08_c.inc"
#include      "param_c.inc"
#include      "task_c.inc"
#include      "sphcom.inc"
#include      "units_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER ,INTENT(IN) :: NSENSOR
      INTEGER NPC(*),IBFV(NIFV,*),
     .        ICODT(*),ICODR(*),ISKEW(*),NINT2 ,IINT2(*),NT_RW
      INTEGER LPBY(*),NPBY(NNPBY,*),ITAB(*),IPARI(NPARI,*),
     .        NRBYAC,IRBYAC(*),NDDL,NDOF(*),
     .        IDDL(*),IKC(*),INLOC(*) ,NDDL0,IERR,IWAR
      my_real RBY(NRBY,*) ,X(3,*) ,SKEW(*)
      my_real TF(*),VEL(LFXVELR,*),XFRAME(NXFRAME,*)
      TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
      TYPE (SENSOR_STR_) ,DIMENSION(NSENSOR) :: SENSOR_TAB
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER NSN,I,J,K,N,M,JI,K10,K11,K12,NS,NN,IRW,ID,IV
      INTEGER NKINE,IKIN(NUMNOD),IOF(NUMNOD),VI(3,NUMNOD)
      INTEGER ISENS,II,IDEB,IT,ICOMP,NTY,IR,IW,NVMAX,NSIZ
      my_real STARTT, STOPT, TS,SS
      CHARACTER*25  MSG_TYPE(2)
      DATA MSG_TYPE / '** WARNING **', '!! ERROR !!'/
C--------implicit imcompability--
        ICOMP = 0
        IT = 1
       IF (ISPMD==0) THEN
         WRITE(IOUT,*)
         WRITE(IOUT,*)' ** INCOMBABILITY CHECKING **'
         WRITE(IOUT,*)
         WRITE(ISTDO,*)
         WRITE(ISTDO,*)' * INCOMBABILITY CHECKING '
       ENDIF
C
        NN = NLASER
        CALL SPMD_MAX_I(NN)
        IF (NN>0.AND.ISPMD==0) THEN
          ICOMP = ICOMP + NN
          IWAR = IWAR +1
          WRITE(IOUT,1100)MSG_TYPE(IT),'IMPACT LASER'
        ENDIF
        IV = 0
        DO N =1,NINTER
         NTY   =IPARI(7,N)
         IF (NTY==2.OR.NTY==7.OR.NTY==10.OR.NTY==11
     .       .OR.NTY==5.OR.NTY==24) THEN
          IF(NTY==7.AND.IPARI(33,N)/=0)THEN
           ICOMP = ICOMP + IPARI(33,N)
           IWAR = IWAR +1
           WRITE(IOUT,1100)MSG_TYPE(IT),'LAGRANGE MULTIPLIER INTERFACE'
          ENDIF
         ELSEIF (NTY>0) THEN
          IWAR = IWAR +1
          ICOMP = ICOMP + 1
C---------------- espere que ca ne arrive pas le contraire -----
          IF (IV<=NUMNOD) THEN
           IV = IV + 1
           VI(1,IV) = NTY
          ENDIF
         ENDIF
        ENDDO
        NVMAX = IV
        CALL SPMD_MAX_I(NVMAX)
        IF (NVMAX>0) THEN
         CALL SPMD_SEND_VI(
     1   IV       ,1     ,VI       ,NVMAX     ,IOUT     )
        ENDIF
        NN = NRIVET
        CALL SPMD_MAX_I(NN)
        IF (NN>0.AND.ISPMD==0) THEN
          ICOMP = ICOMP + NN
          IWAR = IWAR +1
          WRITE(IOUT,1100)MSG_TYPE(IT),'RIVET'
        ENDIF
        NN = NGJOINT
        CALL SPMD_MAX_I(NN)
        IF (NN>0.AND.ISPMD==0) THEN
          ICOMP = ICOMP + NN
         IWAR = IWAR +1
         WRITE(IOUT,1100)MSG_TYPE(IT),'JOINT TYPE SPRINGS'
        ENDIF
        NN = NJOINT
        CALL SPMD_MAX_I(NN)
        IF (NN>0.AND.ISPMD==0) THEN
          ICOMP = ICOMP + NN
         IWAR = IWAR +1
         WRITE(IOUT,1100)MSG_TYPE(IT),'CYLINDRIC JOINT'
        ENDIF
        NN = NUMMPC
        CALL SPMD_MAX_I(NN)
        IF (NN>0.AND.ISPMD==0) THEN
          ICOMP = ICOMP + NN
         IWAR = IWAR +1
         WRITE(IOUT,1100)MSG_TYPE(IT),'MULTI-POINT CONSTRAINTS'
        ENDIF
        NN = NLINK
        CALL SPMD_MAX_I(NN)
        IF (NN>0.AND.ISPMD==0) THEN
         ICOMP = ICOMP + NN
         IWAR = IWAR +1
         WRITE(IOUT,1100)MSG_TYPE(IT),'RIGID LINK'
        ENDIF
        NN = NUMELX
        CALL SPMD_MAX_I(NN)
        IF (NN>0.AND.ISPMD==0) THEN
          ICOMP = ICOMP + NN
         IWAR = IWAR +1
         WRITE(IOUT,1100)MSG_TYPE(IT),'MULTI-PURPOSE ELEMENTS'
        ENDIF
        NN = NUMELS16
        CALL SPMD_MAX_I(NN)
        IF (NN>0.AND.ISPMD==0) THEN
          ICOMP = ICOMP + NN
         IWAR = IWAR +1
         WRITE(IOUT,1100)MSG_TYPE(IT),'SOLID 16n. ELEMENTS'
        ENDIF
        NN = NUMELS20
        CALL SPMD_MAX_I(NN)
        IF (NN>0.AND.ISPMD==0) THEN
          ICOMP = ICOMP + NN
         IWAR = IWAR +1
         WRITE(IOUT,1100)MSG_TYPE(IT),'SOLID 20n. ELEMENTS'
        ENDIF
        NN = NUMELTG6
        CALL SPMD_MAX_I(NN)
        IF (NN>0.AND.ISPMD==0) THEN
          ICOMP = ICOMP + NN
         IWAR = IWAR +1
         WRITE(IOUT,1100)MSG_TYPE(IT),'SHELL S3N6 ELEMENTS'
        ENDIF
        NN = NUMSPH
        CALL SPMD_MAX_I(NN)
        IF (NN>0.AND.ISPMD==0) THEN
          ICOMP = ICOMP + NN
         IWAR = IWAR +1
         WRITE(IOUT,1100)MSG_TYPE(IT),'SPH ELEMENTS'
        ENDIF
C-----------
        IF (ICOMP>0.AND.ISPMD==0) THEN
         WRITE(IOUT,1101) ICOMP
        ENDIF
C--------IKIN: 1 MAIN node of rb, 2 s.n. of int2--,3 s.n. of rb,
C------------: 4 bcs, 5 imposed Dis. ,6 sn of rwall, 7 ns of joint,8 ns os rlink
       NSIZ = 3
      DO N =1,NUMNOD
       IKIN(N)=0
       IF (NDOF(N)>0) THEN
        IOF(N)=2
       ELSE
        IOF(N)=1
       ENDIF
      ENDDO
C----- MAIN of rigid body first------
      IR =0
      DO I=1,NRBYAC
       N=IRBYAC(I)
       M=NPBY(1,N)
       IF (IKIN(M)==0) THEN
        IKIN(M)=1
       ELSE
c        WRITE(IOUT,1001)MSG_TYPE(2),ITAB(M)
        IR = IR + 1
        VI(1,IR) = 1
        VI(2,IR) = 2
        VI(3,IR) = ITAB(M)
       ENDIF
      ENDDO
       SS = IR
       CALL SPMD_SUM_S(SS)
        NVMAX = IR
       CALL SPMD_MAX_I(NVMAX)
       IERR = IERR +INT(SS)
        IF (NVMAX>0) THEN
         CALL SPMD_SEND_VI(
     1   IR       ,NSIZ   ,VI       ,NVMAX     ,IOUT     )
        ENDIF
C------interface 2--------------
      IW =0
      IR =0
      IV =0
      DO I=1,NINT2
       N=IINT2(I)
       NSN = IPARI(5,N)
       JI=IPARI(1,N)
       K10=JI-1
       K11=K10+4*IPARI(3,N)
C------IRECT(4,NSN)-----
       K12=K11+4*IPARI(4,N)
C------NSV(NSN)--node number---
       DO J=1,NSN
        NS=INTBUF_TAB(N)%NSV(J)
        IF (IKIN(NS)==0) THEN
         IKIN(NS)=2
        ELSEIF(IKIN(NS)==1) THEN
c         WRITE(IOUT,1002)MSG_TYPE(1),ITAB(NS)
         IW =IW + 1
         IV =IV + 1
         VI(1,IV) = 2
         VI(2,IV) = 1
         VI(3,IV) = ITAB(NS)
        ELSEIF(IKIN(NS)==2) THEN
c         WRITE(IOUT,1003)MSG_TYPE(2),ITAB(NS)
         IR =IR + 1
         IV =IV + 1
         VI(1,IV) = 3
         VI(2,IV) = 2
         VI(3,IV) = ITAB(NS)
        ENDIF
       ENDDO
      ENDDO
       NVMAX = IV
       CALL SPMD_MAX_I(NVMAX)
       IF (NVMAX>0) THEN
         CALL SPMD_SEND_VI(
     1   IV       ,NSIZ   ,VI       ,NVMAX     ,IOUT     )
       ENDIF
C----- rigid body ------
      IV =0
      DO I=1,NRBYAC
       N=IRBYAC(I)
       K=IRBYAC(I+NRBYKIN)
       M=NPBY(1,N)
       NSN  =NPBY(2,N)
       DO J=1,NSN
        NS=LPBY(K+J)
         IF (IKIN(NS)==0) THEN
          IKIN(NS)=3
         ELSEIF(IKIN(NS)==1) THEN
c          WRITE(IOUT,1004)MSG_TYPE(1),ITAB(NS)
          IW =IW + 1
          IV =IV + 1
          VI(1,IV) = 4
          VI(2,IV) = 1
          VI(3,IV) = ITAB(NS)
         ELSEIF(IKIN(NS)==2) THEN
          IT = MIN(IOF(NS),2)
c          WRITE(IOUT,1005)MSG_TYPE(IT),ITAB(NS)
          IV =IV + 1
          VI(1,IV) = 5
          VI(2,IV) = IT
          VI(3,IV) = ITAB(NS)
          IF (IT==1) THEN
           IW =IW + 1
          ELSEIF (IT==2) THEN
           IR =IR + 1
          ENDIF
         ELSEIF(IKIN(NS)==3) THEN
          IT = MIN(IOF(NS),2)
c          WRITE(IOUT,1006)MSG_TYPE(IT),ITAB(NS)
          IV =IV + 1
          VI(1,IV) = 6
          VI(2,IV) = IT
          VI(3,IV) = ITAB(NS)
          IF (IT==1) THEN
           IW =IW + 1
          ELSEIF (IT==2) THEN
           IR =IR + 1
          ENDIF
         ENDIF
       ENDDO
      ENDDO
       NVMAX = IV
       CALL SPMD_MAX_I(NVMAX)
       IF (NVMAX>0) THEN
         CALL SPMD_SEND_VI(
     1   IV       ,NSIZ   ,VI       ,NVMAX     ,IOUT     )
       ENDIF
C--------bcs---------
      IV =0
      IF (IRODDL==0) THEN
       DO N = 1,NUMNOD
        IF (ICODT(N) > 0) THEN
         IF (IKIN(N)==0) THEN
          IKIN(N)=4
         ELSEIF(IKIN(N)==2) THEN
          IT = MIN(IOF(N),2)
c          WRITE(IOUT,1007)MSG_TYPE(IT),ITAB(N)
          IV =IV + 1
          VI(1,IV) = 7
          VI(2,IV) = IT
          VI(3,IV) = ITAB(N)
          IF (IT==1) THEN
           IW =IW + 1
          ELSEIF (IT==2) THEN
           IR =IR + 1
          ENDIF
         ELSEIF(IKIN(N)==3) THEN
          IT = 1
C          IT = MIN(IOF(N),2)
c          WRITE(IOUT,1008)MSG_TYPE(IT),ITAB(N)
          IV =IV + 1
          VI(1,IV) = 8
          VI(2,IV) = IT
          VI(3,IV) = ITAB(N)
          IF (IT==1) THEN
           IW =IW + 1
          ELSEIF (IT==2) THEN
           IR =IR + 1
          ENDIF
         ENDIF
        ENDIF
       ENDDO
      ELSE
       DO N = 1,NUMNOD
        IF ((ICODT(N)+ICODR(N))>0 ) THEN
         IF (IKIN(N)==0) THEN
          IKIN(N)=4
         ELSEIF(IKIN(N)==2) THEN
          IT = MIN(IOF(N),2)
c          WRITE(IOUT,1007)MSG_TYPE(IT),ITAB(N)
          IV =IV + 1
          VI(1,IV) = 7
          VI(2,IV) = IT
          VI(3,IV) = ITAB(N)
          IF (IT==1) THEN
           IW =IW + 1
          ELSEIF (IT==2) THEN
           IR =IR + 1
          ENDIF
         ELSEIF(IKIN(N)==3) THEN
          IT = 1
C          IT = MIN(IOF(N),2)
c          WRITE(IOUT,1008)MSG_TYPE(IT),ITAB(N)
          IV =IV + 1
          VI(1,IV) = 8
          VI(2,IV) = IT
          VI(3,IV) = ITAB(N)
          IF (IT==1) THEN
           IW =IW + 1
          ELSEIF (IT==2) THEN
           IR =IR + 1
          ENDIF
         ENDIF
        ENDIF
       ENDDO
      ENDIF
       NVMAX = IV
       CALL SPMD_MAX_I(NVMAX)
       IF (NVMAX>0) THEN
         CALL SPMD_SEND_VI(
     1   IV       ,NSIZ   ,VI       ,NVMAX     ,IOUT     )
       ENDIF
C--------fxv---------
      IV =0
      DO NN=1,NFXVEL,NVSIZ
        IF (IBFV(8,NN)==1) GOTO 100
        IF (NSENSOR>0) THEN
          DO 10 II = 1, MIN(NFXVEL-IDEB,NVSIZ)
            N = II+IDEB
            STARTT = VEL(2,N)
            STOPT  = VEL(3,N)
            IF(TT<STARTT)GOTO 10
            IF(TT>STOPT) GOTO 10
            I=IABS(IBFV(1,N))
            ISENS=0
            DO K=1,NSENSOR
              IF(IBFV(4,N)==SENSOR_TAB(K)%SENS_ID) ISENS=K
            ENDDO
            IF(ISENS==0)THEN
              TS=TT
            ELSE
              TS = TT-SENSOR_TAB(ISENS)%TSTART
              IF(TS<ZERO)GOTO 10
            ENDIF
            IF (IKIN(I)==0) THEN
             IKIN(I)=5
            ELSEIF(IKIN(I)==2) THEN
c             WRITE(IOUT,1009)MSG_TYPE(2),ITAB(I)
             IV =IV + 1
             VI(1,IV) = 9
             VI(2,IV) = 2
             VI(3,IV) = ITAB(I)
             IR =IR + 1
            ELSEIF(IKIN(I)==3) THEN
c             WRITE(IOUT,1010)MSG_TYPE(2),ITAB(I)
             IV =IV + 1
             VI(1,IV) = 10
             VI(2,IV) = 1
             VI(3,IV) = ITAB(I)
             IW =IW + 1
            ELSEIF(IKIN(I)==4) THEN
c             WRITE(IOUT,1011)MSG_TYPE(2),ITAB(I)
             IV =IV + 1
             VI(1,IV) = 11
             VI(2,IV) = 2
             VI(3,IV) = ITAB(I)
             IR =IR + 1
            ENDIF
 10       CONTINUE
        ELSE
          DO 20 II = 1, MIN(NFXVEL-IDEB,NVSIZ)
            N = II+IDEB
            STARTT = VEL(2,N)
            STOPT  = VEL(3,N)
            IF(TT<STARTT)GOTO 20
            IF(TT>STOPT) GOTO 20
            I=IABS(IBFV(1,N))
            IF (IKIN(I)==0) THEN
             IKIN(I)=5
            ELSEIF(IKIN(I)==2) THEN
c             WRITE(IOUT,1009)MSG_TYPE(2),ITAB(I)
             IV =IV + 1
             VI(1,IV) = 9
             VI(2,IV) = 2
             VI(3,IV) = ITAB(I)
             IR =IR + 1
            ELSEIF(IKIN(I)==3) THEN
c             WRITE(IOUT,1010)MSG_TYPE(2),ITAB(I)
             IV =IV + 1
             VI(1,IV) = 10
             VI(2,IV) = 1
             VI(3,IV) = ITAB(I)
             IW =IW + 1
            ELSEIF(IKIN(I)==4) THEN
c             WRITE(IOUT,1011)MSG_TYPE(2),ITAB(I)
             IV =IV + 1
             VI(1,IV) = 11
             VI(2,IV) = 2
             VI(3,IV) = ITAB(I)
             IR =IR + 1
            ENDIF
 20       CONTINUE
        ENDIF
C
        IDEB = IDEB + MIN(NFXVEL-IDEB,NVSIZ)
 100    CONTINUE
      ENDDO
       NVMAX = IV
       CALL SPMD_MAX_I(NVMAX)
       IF (NVMAX>0) THEN
         CALL SPMD_SEND_VI(
     1   IV       ,NSIZ   ,VI       ,NVMAX     ,IOUT     )
       ENDIF
C--------rwall---------
      IV =0
      IF (NT_RW>0) THEN
       DO I = 1,NUMNOD
        K = MIN(3,NDOF(I))
        IRW = 0
        DO J =1,K
         ID = IDDL(I) + J
         IF (IKC(ID)==4.OR.IKC(ID)==11) IRW = 1
        ENDDO
        IF (IRW>0) THEN
         IF (IKIN(I)==0) THEN
          IKIN(I)=6
         ELSEIF(IKIN(I)==2) THEN
c          WRITE(IOUT,1012)MSG_TYPE(2),ITAB(I)
             IV =IV + 1
             VI(1,IV) = 12
             VI(2,IV) = 2
             VI(3,IV) = ITAB(I)
             IR =IR + 1
         ELSEIF(IKIN(I)==3) THEN
c          WRITE(IOUT,1013)MSG_TYPE(2),ITAB(I)
             IV =IV + 1
             VI(1,IV) = 13
             VI(2,IV) = 1
             VI(3,IV) = ITAB(I)
             IW =IW + 1
         ELSEIF(IKIN(I)==4) THEN
c          WRITE(IOUT,1014)MSG_TYPE(2),ITAB(I)
             IV =IV + 1
             VI(1,IV) = 14
             VI(2,IV) = 2
             VI(3,IV) = ITAB(I)
             IR =IR + 1
         ELSEIF(IKIN(I)==5) THEN
c          WRITE(IOUT,1015)MSG_TYPE(1),ITAB(I)
             IV =IV + 1
             VI(1,IV) = 15
             VI(2,IV) = 1
             VI(3,IV) = ITAB(I)
             IW =IW + 1
         ENDIF
        ENDIF
       ENDDO
      ENDIF
C
       NVMAX = IV
       CALL SPMD_MAX_I(NVMAX)
       IF (NVMAX>0) THEN
         CALL SPMD_SEND_VI(
     1   IV       ,NSIZ   ,VI       ,NVMAX     ,IOUT     )
       ENDIF
        SS = IR
        CALL SPMD_SUM_S(SS)
        IR = INT(SS)
        SS = IW
        CALL SPMD_SUM_S(SS)
        IW = INT(SS)
       IERR = IERR +IR
       IWAR = IWAR +IW
       RETURN
 1100 FORMAT(A,' IMPLICIT IS INCOMPABLE WITH :',A/)
 1101 FORMAT(/'**STIFFNESS WILL BE IGNORED WITH',1X,I8,
     .        ' INCOMPABLE OPTIONS**'/)
      END
C endif MUMPS defined
#endif 

Chd|====================================================================
Chd|  IMP_FOUT                      source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        RESOL                         source/engine/resol.F         
Chd|-- calls ---------------
Chd|        H3D_MOD                       share/modules/h3d_mod.F       
Chd|        IMPBUFDEF_MOD                 share/modules/impbufdef_mod.F 
Chd|====================================================================
      SUBROUTINE IMP_FOUT(
     1          FANI     ,A        ,AR       ,NFIA      ,NFEA       ,
     2          NODFT    ,NODLT    ,H3D_DATA ,IMPBUF_TAB)
C-----------------------------------------------
C   M o d u l e s
C----------------------------------------------- 
      USE H3D_MOD 
      USE IMPBUFDEF_MOD
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "scr14_c.inc"
#include      "scr16_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NFIA,NFEA,NODFT,NODLT
C     REAL
      my_real
     .   A(3,*)    ,AR(3,*)    ,FANI(3,*)
      TYPE(H3D_DATABASE) :: H3D_DATA
      TYPE (IMPBUF_STRUCT_) ,TARGET :: IMPBUF_TAB
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER N,I,J,K,ND
      INTEGER, DIMENSION(:) ,POINTER     :: IDDL,NDOF,IKC
C-------------mis  zero Fint des noeuds dependants------------
          IDDL => IMPBUF_TAB%IDDL
          NDOF => IMPBUF_TAB%NDOF
          IKC => IMPBUF_TAB%IKC
      IF(ANIM_V(5)+OUTP_V(5)+H3D_DATA%N_VECT_FINT>0) THEN
       DO I = NODFT,NODLT
        DO J=1,MIN(3,NDOF(I))
         ND = IDDL(I)+J
         IF (IKC(ND)/=0) FANI(J,I+NFIA)= ZERO
        ENDDO
        IF (NDOF(I)==0) THEN
         FANI(1,I+NFIA)= ZERO
         FANI(2,I+NFIA)= ZERO
         FANI(3,I+NFIA)= ZERO
        ENDIF
       ENDDO
      ENDIF
C
      RETURN
      END
Chd|====================================================================
Chd|  IMP_FANII                     source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        RESOL                         source/engine/resol.F         
Chd|-- calls ---------------
Chd|        H3D_MOD                       share/modules/h3d_mod.F       
Chd|====================================================================
      SUBROUTINE IMP_FANII(
     1          FANI     ,FINT     ,NFIA      ,NODFT    ,NODLT    ,
     2          H3D_DATA )
C-----------------------------------------------
C   M o d u l e s
C----------------------------------------------- 
      USE H3D_MOD 
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "scr14_c.inc"
#include      "scr16_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NFIA,NODFT,NODLT
C     REAL
      my_real
     .   FINT(3,*)    ,FANI(3,*)
      TYPE(H3D_DATABASE) :: H3D_DATA
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER N,I,J,K,ND
C---
      IF(ANIM_V(5)+OUTP_V(5)+H3D_DATA%N_VECT_FINT>0) THEN
#include      "vectorize.inc"
          DO N=NODFT,NODLT
            FANI(1,N+NFIA)= FINT(1,N)
            FANI(2,N+NFIA)= FINT(2,N)
            FANI(3,N+NFIA)= FINT(3,N)
          ENDDO
      ENDIF
C
      RETURN
      END
Chd|====================================================================
Chd|  IMP_FANIE                     source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        RESOL                         source/engine/resol.F         
Chd|-- calls ---------------
Chd|        H3D_MOD                       share/modules/h3d_mod.F       
Chd|====================================================================
      SUBROUTINE IMP_FANIE(
     1          FANI   ,FEXT   ,NFIA   ,NFEA     ,NODFT    ,NODLT    ,
     2          H3D_DATA )
C-----------------------------------------------
C   M o d u l e s
C----------------------------------------------- 
      USE H3D_MOD 
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "scr14_c.inc"
#include      "scr16_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NFIA,NFEA,NODFT,NODLT
C     REAL
      my_real
     .   FEXT(3,*)    ,FANI(3,*)
      TYPE(H3D_DATABASE) :: H3D_DATA
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER N,I,J,K,ND
C---
      IF(ANIM_V(5)+OUTP_V(5)+H3D_DATA%N_VECT_FINT>0) THEN
#include      "vectorize.inc"
          DO N=NODFT,NODLT
            FANI(1,N+NFIA)= -FEXT(1,N)
            FANI(2,N+NFIA)= -FEXT(2,N)
            FANI(3,N+NFIA)= -FEXT(3,N)
          ENDDO
      ENDIF
      IF(ANIM_V(6)+OUTP_V(6)+H3D_DATA%N_VECT_FEXT>0) THEN
#include      "vectorize.inc"
          DO N=NODFT,NODLT
            FANI(1,N+NFEA)= FEXT(1,N)
            FANI(2,N+NFEA)= FEXT(2,N)
            FANI(3,N+NFEA)= FEXT(3,N)
          ENDDO
      ENDIF
      RETURN
      END
Chd|====================================================================
Chd|  INI_KIC                       source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_BUCK                      source/implicit/imp_buck.F    
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        IMP_INTM                      share/modules/imp_intm.F      
Chd|====================================================================
      SUBROUTINE INI_KIC
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE IMP_INTM
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      NDDL_SI = 0
      NDDL_SL = 0
      NZ_SI = 0
      NZ_SL = 0
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  DEALLOCM                      source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        IMP_KNON                      share/modules/impbufdef_mod.F 
Chd|====================================================================
      SUBROUTINE DEALLOCM
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE IMP_KNON
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        IF(ALLOCATED(IN_KN)) DEALLOCATE(IN_KN)
        IF(ALLOCATED(ID_KN)) DEALLOCATE(ID_KN)
       IF (NUMN_KN>0) THEN
        IF(ALLOCATED(ID_KNM)) DEALLOCATE(ID_KNM)
        IF(ALLOCATED(ID_KNM2)) DEALLOCATE(ID_KNM2)
        IF(ALLOCATED(ID_KNM3)) DEALLOCATE(ID_KNM3)
        IF(ALLOCATED(II2_KN)) DEALLOCATE(II2_KN)
        IF(ALLOCATED(IRB_KN)) DEALLOCATE(IRB_KN)
        IF(ALLOCATED(IBC_KN)) DEALLOCATE(IBC_KN)
        IF(ALLOCATED(IFX_KN)) DEALLOCATE(IFX_KN)
        IF(ALLOCATED(IRW_KN)) DEALLOCATE(IRW_KN)
        IF(ALLOCATED(IRBE3_KN)) DEALLOCATE(IRBE3_KN)
        IF(ALLOCATED(FCDI_KN)) DEALLOCATE(FCDI_KN)
        IF(ALLOCATED(MCDI_KN)) DEALLOCATE(MCDI_KN)
       ENDIF
C------------------------------------------
      RETURN
      END

#if defined(MUMPS5) 
Chd|====================================================================
Chd|  DEALLOCM_IMP                  source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        RESOL                         source/engine/resol.F         
Chd|-- calls ---------------
Chd|        FVBC_DEALLO                   source/constraints/general/impvel/fv_imp0.F
Chd|        SPMD_MUMPS_DEAL               source/mpi/implicit/imp_spmd.F
Chd|        IMP_BFGS                      share/modules/impbufdef_mod.F 
Chd|        IMP_DYNA                      share/modules/impbufdef_mod.F 
Chd|        IMP_INTBUF                    share/modules/imp_mod_def.F   
Chd|        IMP_KBCS                      share/modules/impbufdef_mod.F 
Chd|        IMP_PCG_PROJ                  share/modules/impbufdef_mod.F 
Chd|        IMP_QSTAT                     share/modules/impbufdef_mod.F 
Chd|        IMP_SPBRM                     share/modules/impbufdef_mod.F 
Chd|        IMP_WORKH                     share/modules/impbufdef_mod.F 
Chd|====================================================================
      SUBROUTINE DEALLOCM_IMP(MUMPS_PAR)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE IMP_KBCS
      USE IMP_BFGS
      USE IMP_DYNA
      USE IMP_WORKH
      USE IMP_PCG_PROJ
      USE IMP_QSTAT
      USE IMP_SPBRM
      USE IMP_INTBUF
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include "com01_c.inc"
#include "impl1_c.inc"
#include "impl2_c.inc"
#include "dmumps_struc.h"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      TYPE(DMUMPS_STRUC) MUMPS_PAR
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
       IF(IMUMPSV > 0 ) CALL SPMD_MUMPS_DEAL(MUMPS_PAR) 
       IF (ISOLV>2) THEN
        IF(ALLOCATED(HOLD)) DEALLOCATE(HOLD)
       ENDIF
       IF (INSOLV>1) THEN
        IF(ALLOCATED(BFGS_V)) DEALLOCATE(BFGS_V)
        IF(ALLOCATED(BFGS_W)) DEALLOCATE(BFGS_W)
       ENDIF
       IF (IDYNA>0) THEN
        IF(ALLOCATED(DY_D)) DEALLOCATE(DY_D)
        IF(ALLOCATED(DY_DR)) DEALLOCATE(DY_DR)
        IF(ALLOCATED(DY_V)) DEALLOCATE(DY_V)
        IF(ALLOCATED(DY_VR)) DEALLOCATE(DY_VR)
c        IF(ALLOCATED(DY_A)) DEALLOCATE(DY_A)
c        IF(ALLOCATED(DY_AR)) DEALLOCATE(DY_AR)
        IF (IDY_DAMP>0) THEN
         DEALLOCATE(DY_DIAK0,DY_LTK0)
         DEALLOCATE(DY_IADK0,DY_JDIK0)
        ENDIF
        IF (HHT_A/=ZERO)DEALLOCATE(DY_R0,DY_R1)
       ENDIF
C---------------lin_solv--------
        IF(ALLOCATED(L_U)) DEALLOCATE(L_U)
        IF(ALLOCATED(DIAG_T)) DEALLOCATE(DIAG_T)
        IF(ALLOCATED(L_F0)) DEALLOCATE(L_F0)
       IF (ISOLV==1.OR.ISOLV>4) THEN
        IF(ALLOCATED(IADK0)) DEALLOCATE(IADK0)
        IF(ALLOCATED(JDIK0)) DEALLOCATE(JDIK0)
        IF(ALLOCATED(LT_K0)) DEALLOCATE(LT_K0)
        IF(ALLOCATED(PCG_W1)) DEALLOCATE(PCG_W1)
        IF(ALLOCATED(PCG_W2)) DEALLOCATE(PCG_W2)
        IF(ALLOCATED(PCG_W3)) DEALLOCATE(PCG_W3)
        IF (IPREC==5) THEN
         IF(ALLOCATED(IADM0)) DEALLOCATE(IADM0)
         IF(ALLOCATED(JDIM0)) DEALLOCATE(JDIM0)
         IF(ALLOCATED(LT_M0)) DEALLOCATE(LT_M0)
        ENDIF
        IF (M_VS>0) THEN
         IF(ALLOCATED(PROJ_S)) DEALLOCATE(PROJ_S)
         IF(ALLOCATED(PROJ_T)) DEALLOCATE(PROJ_T)
         IF(ALLOCATED(PROJ_LA_1)) DEALLOCATE(PROJ_LA_1)
         IF(ALLOCATED(PROJ_V)) DEALLOCATE(PROJ_V)
         IF(ALLOCATED(PROJ_W)) DEALLOCATE(PROJ_W)
         IF(ALLOCATED(PROJ_K)) DEALLOCATE(PROJ_K)
        ENDIF
       ENDIF
      IF(IQSTAT==1 .AND. ILINE==0) THEN
       DEALLOCATE(D_N_1)
       IF (IRODDL/=0) DEALLOCATE(DR_N_1)
      END IF
      CALL FVBC_DEALLO
      IF (IRIG_M>0) THEN
       IF(ALLOCATED(IBC_B)) DEALLOCATE(IBC_B)
       IF(ALLOCATED(IE_BC4)) DEALLOCATE(IE_BC4)
       IF(ALLOCATED(IE_BC3)) DEALLOCATE(IE_BC3)
      END IF
C------    faire---       
c      IF (NINTER>0) THEN
c       IF(ALLOCATED(INTBUF_TAB_CP)) DEALLOCATE(INTBUF_TAB_CP)
c       IF(ALLOCATED(INTBUF_TAB_IMP)) DEALLOCATE(INTBUF_TAB_IMP)
c       IF(ALLOCATED(BMINMA_IMP)) DEALLOCATE(BMINMA_IMP)
c      END IF
C------------------------------------------
      RETURN
      END
#endif
Chd|====================================================================
Chd|  CRIT_LLIM                     source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|====================================================================
      SUBROUTINE CRIT_LLIM(NDDL,NNZK)
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "task_c.inc"
#include      "impl1_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      INTEGER NDDL,NNZK
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,JD,NP
      my_real
     .  PFAC,CRITL,S1,S2
C------compute auto seclect solver by L_LIM--------------
C--------take into account to parallel capacities of PCG---
       IF (NSPMD == 1) THEN
        NDDL_G = NDDL
        NNZK_G = NNZK
       END IF
       NP=NSPMD/2
       PFAC= TWO_THIRD*NTHREAD*MAX(1,NP)
       PFAC=MAX(ONE,PFAC)
       S1=NDDL_G*FIVE*EM03
       S2=NNZK_G*TWOP8*EM04
       CRITL=HALF*(S1+S2)
       L_LIM=CRITL*PFAC
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  INI_K0H                       source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_CHKM                      source/implicit/imp_solv.F    
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        ANCMSG                        source/output/message/message.F
Chd|        ARRET                         source/system/arret.F         
Chd|        DIM_SPAN                      source/implicit/ind_glob_k.F  
Chd|        IMP_PCG_PROJ                  share/modules/impbufdef_mod.F 
Chd|        IMP_WORKH                     share/modules/impbufdef_mod.F 
Chd|        MESSAGE_MOD                   share/message_module/message_mod.F
Chd|====================================================================
      SUBROUTINE INI_K0H(NDDL,NNZ,NNZM,IADK,JDIK)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE IMP_WORKH
      USE IMP_PCG_PROJ
      USE MESSAGE_MOD
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "impl1_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NDDL,NNZ,NNZM,IADK(*),JDIK(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER IERR,LNZM
C------------------for lin_solv---------------
         ALLOCATE(L_U(NDDL),DIAG_T(NDDL),L_F0(NDDL),STAT=IERR)
         IF (IERR/=0) THEN
           CALL ANCMSG(MSGID=19,ANMODE=ANINFO,
     .                 C1='FOR IMPLICIT SOLVER')
           CALL ARRET(2)
         ENDIF
      IF (ISOLV==1.OR.ISOLV>4) THEN
       ALLOCATE(PCG_W1(NDDL),PCG_W2(NDDL),PCG_W3(NDDL),STAT=IERR)
       ALLOCATE(IADK0(NDDL+1),JDIK0(NNZ),LT_K0(NNZ),STAT=IERR)
         IF (IERR/=0) THEN
           CALL ANCMSG(MSGID=19,ANMODE=ANINFO,
     .                 C1='FOR PCG SOLVER')
           CALL ARRET(2)
         ENDIF
       LT_K0=ZERO
       IF (IPREC==5) THEN
        LNZM = NNZM
        IF (N_PAT>1) CALL DIM_SPAN(N_PAT,NDDL,IADK,JDIK,LNZM,IERR)
        ALLOCATE(IADM0(NDDL+1),JDIM0(LNZM),LT_M0(LNZM),STAT=IERR)
         IF (IERR/=0) THEN
           CALL ANCMSG(MSGID=19,ANMODE=ANINFO,
     .                 C1='FOR PCG(IPREC=5) SOLVER')
           CALL ARRET(2)
         ENDIF
        LT_M0=ZERO
       END IF !(IPREC==5) THEN
      END IF !(ISOLV==1.OR.ISOLV>4) THEN
C
      IF (M_VS>0) THEN
        LNZM=M_VS+1
        ALLOCATE(PROJ_S(NDDL,LNZM),PROJ_T(NDDL,LNZM),PROJ_LA_1(LNZM),
     .                  PROJ_V(NDDL),PROJ_W(LNZM),PROJ_K(LNZM,LNZM),
     .                  STAT=IERR)
         IF (IERR/=0) THEN
           CALL ANCMSG(MSGID=19,ANMODE=ANINFO,
     .                 C1='FOR PCG SOLVER')
           CALL ARRET(2)
         ENDIF
         NCG_RUN = 0
         PROJ_V = ZERO
      END IF
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  SET_KSYM                      source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        LIN_SOLV                      source/implicit/lin_solv.F    
Chd|        LIN_SOLVH0                    source/implicit/lin_solv.F    
Chd|        LIN_SOLVH1                    source/implicit/lin_solv.F    
Chd|        LIN_SOLVHM                    source/implicit/lin_solv.F    
Chd|        LIN_SOLVIH2                   source/implicit/lin_solv.F    
Chd|-- calls ---------------
Chd|====================================================================
      SUBROUTINE SET_KSYM(NDDL,IADK,JDIK,LT_K,IADK0,JDIK0,LT_K0)
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER  NDDL,IADK(*),JDIK(*),IADK0(*),JDIK0(*)
      my_real
     .  LT_K(*),LT_K0(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER  I,J,K,JD,ICOL(NDDL),NRI,NR0
C----6--K0:matrice complete(non triang)
      DO I = 1, NDDL
        ICOL(I) = IADK(I+1) - IADK(I)
      ENDDO
      DO I = 1, NDDL
        DO J = IADK(I),IADK(I+1)-1
         JD = JDIK(J)
         ICOL(JD) = ICOL(JD) + 1
        ENDDO
      ENDDO
      IADK0(1) = 1
      DO I = 1,NDDL
       IADK0(I+1) = IADK0(I)+ICOL(I)-IADK(I+1)+IADK(I)
       ICOL(I) = 0
      ENDDO
      DO I = 1,NDDL
        DO J=IADK(I),IADK(I+1)-1
         JD = JDIK(J)
         K = IADK0(JD) + ICOL(JD)
         JDIK0(K) = I
         LT_K0(K) = LT_K(J)
         ICOL(JD) = ICOL(JD) + 1
        ENDDO
      ENDDO
C
      RETURN
      END

Chd|====================================================================
Chd|  GET_FEXT                      source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        CONDENS_B                     source/implicit/upd_glob_k.F  
Chd|        IMP_SETBA                     source/implicit/imp_setb.F    
Chd|        IMP_SETBP                     source/implicit/imp_setb.F    
Chd|        SPMD_SUMF_V                   source/mpi/implicit/imp_spmd.F
Chd|====================================================================
      SUBROUTINE GET_FEXT(NDDL0 ,NDDL   ,IDDL   ,NDOF   ,IKC   ,
     1                    INLOC ,LB     ,FEXT   ,AC     ,ACR   )
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com08_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NDDL0 ,NDDL   ,IDDL(*),NDOF(*),IKC(*),INLOC(*)
      my_real
     .  LB(*),FEXT(*),AC(*),ACR(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J
      my_real
     .  BFAC,NTMP
C-----------------------------------------------
          IF (ABS(TT)<EM20) RETURN
          BFAC=TSTOP/TT
         IF (NSPMD>1) THEN
C -------------------------------
            NTMP = 0
            DO I=1,NDDL0
             FEXT(I)=LB(I)
            ENDDO
            CALL IMP_SETBA(AC    ,ACR      ,IDDL   ,NDOF  ,FEXT    ,
     1                     NTMP  )
            CALL CONDENS_B(NDDL0  ,IKC  ,FEXT)
            CALL SPMD_SUMF_V(FEXT)
            CALL IMP_SETBP(AC    ,ACR    ,IDDL   ,NDOF   ,IKC   ,
     .                     INLOC ,FEXT   )
            DO I=1,NDDL
             FEXT(I)=BFAC*FEXT(I)
            ENDDO
         ELSE
            DO I=1,NDDL0
             FEXT(I)=BFAC*LB(I)
            ENDDO
            CALL CONDENS_B(NDDL0  ,IKC  ,FEXT  )
         END IF
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  RE2INT5                       source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        RESOL                         source/engine/resol.F         
Chd|-- calls ---------------
Chd|====================================================================
      SUBROUTINE RE2INT5(NT_IMP,NUMIMP,NS_IMP,NE_IMP,NUMIMPL,
     1                   IPARI ,NT_IMP0)
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "task_c.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER  NT_IMP,NUMIMP(*),NS_IMP(*),NE_IMP(*),
     .         NUMIMPL(NINTER,*),IPARI(NPARI,*),NT_IMP0
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,K,L,N,IAD,IAD1,IADT,ITY,L_CP,L_CPJ,NIMPJ,
     .        IADN(NTHREAD)
      INTEGER, DIMENSION(:),ALLOCATABLE :: NS_CP,NE_CP
      INTEGER IER1
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
C-----------------------------------------
        NT_IMP = 0
        IADT = 0
        L_CPJ = 0
        DO J = 1,NTHREAD
         NIMPJ = IADT
        DO N = 1,NINTER
         ITY   =IPARI(7,N)
         IF (ITY==3.OR.ITY==4.OR.ITY==5) THEN
           NUMIMP(N)=0
           IADT =IADT + NUMIMPL(N,J)
         END IF
        END DO 
         NIMPJ = -NIMPJ+IADT
         L_CPJ = MAX(L_CPJ,NIMPJ)
        END DO
        IF (IADT==0) RETURN
C
        IF (NTHREAD==1) THEN
         DO N = 1,NINTER
          NUMIMP(N) =NUMIMPL(N,1)
         END DO
        ELSE
         L_CP = L_CPJ*NTHREAD
         ALLOCATE(NS_CP(L_CP),NE_CP(L_CP),STAT=IER1)
C
          IAD=0
         DO J = 1,NTHREAD
      IAD1=(J-1)*NT_IMP0
          DO I = 1,L_CPJ
       NS_CP(IAD+I) = NS_IMP(IAD1+I)
           NE_CP(IAD+I) = NE_IMP(IAD1+I)
          END DO
          IAD =IAD + L_CPJ
          IADN(J) =0
         END DO
C
         IAD = 0
         DO N = 1,NINTER
          ITY   =IPARI(7,N)
          NUMIMP(N)=0
          IF (ITY==3.OR.ITY==4.OR.ITY==5) THEN
          DO J = 1,NTHREAD
           IAD1=(J-1)*L_CP/ NTHREAD + IADN(J)
           DO I = 1,NUMIMPL(N,J)
            NS_IMP(IAD+I) = NS_CP(IAD1+I)
            NE_IMP(IAD+I) = NE_CP(IAD1+I)
           END DO
           IAD =IAD + NUMIMPL(N,J)
           NUMIMP(N) = NUMIMP(N)+NUMIMPL(N,J)
           IADN(J) = IADN(J) + NUMIMPL(N,J)
C-------reput zero
           NUMIMPL(N,J)=0
          END DO
          END IF
         END DO
         DEALLOCATE(NS_CP,NE_CP)
        END IF !(NTHREAD==1) THEN
C
        NT_IMP = NT_IMP + IADT
C
      RETURN
      END
Chd|====================================================================
Chd|  RE2INT7                       source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        RESOL                         source/engine/resol.F         
Chd|-- calls ---------------
Chd|        IMP_STIF24                    source/implicit/imp_solv.F    
Chd|====================================================================
      SUBROUTINE RE2INT7(NT_IMP,NUMIMP,NS_IMP,NE_IMP,IND_IMP,
     1                   NUMIMPL,IPARI,NT_IMP0)
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "task_c.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER  NT_IMP,NUMIMP(*),NS_IMP(*),NE_IMP(*),IND_IMP(*),
     .         NUMIMPL(NINTER,*),IPARI(NPARI,*),NT_IMP0
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,K,L,N,IAD,IAD1,IADT,ITY,IAD0,L_CP,L_CPJ,NIMPJ,
     .        NT_IMP7,IADN(NTHREAD)
      INTEGER, DIMENSION(:),ALLOCATABLE :: NS_CP,NE_CP,IND_CP
      INTEGER IER1
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
        IADT = 0
        L_CPJ = 0
        DO J = 1,NTHREAD
         NIMPJ = IADT
         DO N = 1,NINTER
          ITY   =IPARI(7,N)
          IF (ITY==7.OR.ITY==10.OR.ITY==11.OR.ITY==24) THEN
           NUMIMP(N)=0
           IADT =IADT + NUMIMPL(N,J)
          END IF
         END DO
         NIMPJ = -NIMPJ+IADT
         L_CPJ = MAX(L_CPJ,NIMPJ)
        END DO
        IF (IADT==0) GOTO 100
        
        IF (NTHREAD==1) THEN
             DO N = 1,NINTER
              NUMIMP(N) =NUMIMPL(N,1)
             END DO
        ELSE
         L_CP = L_CPJ*NTHREAD
          ALLOCATE(NS_CP(L_CP),NE_CP(L_CP),IND_CP(L_CP),STAT=IER1)
        
             IAD0=NT_IMP
             NT_IMP7=NT_IMP0-NT_IMP
             IAD =0
         DO J = 1,NTHREAD
          IAD1=IAD0+(J-1)*NT_IMP7
          DO I = 1,L_CPJ
           NS_CP(IAD+I) = NS_IMP(IAD1+I)
           NE_CP(IAD+I) = NE_IMP(IAD1+I)
           IND_CP(IAD+I) = IND_IMP(IAD1+I)
          END DO
           IAD =IAD + L_CPJ
           IADN(J) =0
         END DO
        
             IAD = IAD0
         DO N = 1,NINTER
          ITY   =IPARI(7,N)
          IF (ITY==7.OR.ITY==10.OR.ITY==11.OR.ITY==24) THEN
          DO J = 1,NTHREAD
           IAD1=(J-1)*L_CP/ NTHREAD + IADN(J)
           DO I = 1,NUMIMPL(N,J)
            NS_IMP(IAD+I) = NS_CP(IAD1+I)
            NE_IMP(IAD+I) = NE_CP(IAD1+I)
            IND_IMP(IAD+I) = IND_CP(IAD1+I)
           END DO
           IAD =IAD + NUMIMPL(N,J)
           NUMIMP(N) = NUMIMP(N)+NUMIMPL(N,J)
           IADN(J) = IADN(J) + NUMIMPL(N,J)
C        ----reput zero
           NUMIMPL(N,J)=0
          END DO
          END IF
         END DO
         DEALLOCATE(NS_CP,NE_CP,IND_CP)
        END IF !(NTHREAD==1) THEN
C
        NT_IMP = NT_IMP + IADT
C-------int24, Istif=6
 100  CONTINUE
      CALL IMP_STIF24(NUMIMP  ,IPARI   )
      RETURN
      END
Chd|====================================================================
Chd|  DU_INI                        source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|-- calls ---------------
Chd|        IMP_DYNA                      share/modules/impbufdef_mod.F 
Chd|====================================================================
      SUBROUTINE DU_INI(NODFT ,NODLT  ,DN     ,DNR    ,DD    ,
     1                  DDR   ,IDIV   ,ICONT0 )
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE IMP_DYNA
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "impl1_c.inc"
#include      "impl2_c.inc"
#include      "com01_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NODFT ,NODLT,IDIV   ,ICONT0
      my_real
     . DN(3,*),DNR(3,*),DD(3,*),DDR(3,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,IRES
      my_real
     .  BFAC,BDT
C--------------Dn,0=Dn-1--------
C--------special case with /QSTAT diverge by contact, restart w/o resolution
        IRES = 1
        IF (IQSTAT >0 .AND. IDIV==-2 .AND. ICONT0 >0 ) THEN
         IDIV=-1
         IRES=0
        END IF
C        
        BFAC=DT1_IMP/DT0_IMP
        IF (IDYNA==0) THEN
         IF (ISMDISP>0.OR.IRES==0) THEN
          DO I = NODFT ,NODLT
           DD(1,I) = BFAC*DN(1,I)
           DD(2,I) = BFAC*DN(2,I)
           DD(3,I) = BFAC*DN(3,I)
          END DO
          IF (IRODDL/=0) THEN
           DO I = NODFT ,NODLT
            DDR(1,I) = BFAC*DNR(1,I)
            DDR(2,I) = BFAC*DNR(2,I)
            DDR(3,I) = BFAC*DNR(3,I)
           END DO
          END IF
         ELSE
          DO I = NODFT ,NODLT
          DD(1,I) = DN(1,I)
          DD(2,I) = DN(2,I)
          DD(3,I) = DN(3,I)
         ENDDO
         IF (IRODDL/=0) THEN
          DO I = NODFT ,NODLT
           DDR(1,I) = DNR(1,I)
           DDR(2,I) = DNR(2,I)
           DDR(3,I) = DNR(3,I)
          ENDDO
          END IF
         END IF
        ELSE
         BDT = HALF*DT0_IMP*DT0_IMP*(ONE-TWO*DY_B)
         BDT = ZERO
         DO I = NODFT ,NODLT
          DD(1,I) = BFAC*DN(1,I)+BDT*DY_A(1,I)
          DD(2,I) = BFAC*DN(2,I)+BDT*DY_A(2,I)
          DD(3,I) = BFAC*DN(3,I)+BDT*DY_A(3,I)
         END DO
         IF (IRODDL/=0) THEN
          DO I = NODFT ,NODLT
           DDR(1,I) = BFAC*DNR(1,I)+BDT*DY_AR(1,I)
           DDR(2,I) = BFAC*DNR(2,I)+BDT*DY_AR(2,I)
           DDR(3,I) = BFAC*DNR(3,I)+BDT*DY_AR(3,I)
          END DO
         END IF
        END IF
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  PR_DEB                        source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|-- calls ---------------
Chd|        IMP_FRK                       share/modules/impbufdef_mod.F 
Chd|        IMP_INTM                      share/modules/imp_intm.F      
Chd|====================================================================
      SUBROUTINE PR_DEB(NDDL  ,IDDL  ,NDOF   ,IKC   ,ITAB   ,
     1                  DIAG_K,DIAG_M,INLOC  ,FR_ELEM,IAD_ELEM,
     2                  IADK  ,JDIK  ,LT_K   ,LT_M   ,NDDLI  ,
     3                  IADI  ,JDII  ,ITOK   ,DIAG_I ,LT_I   ,
     4                  U     ,F     ,IT     ,NSREM  ,NSL    ,
     5                  D     ,DR    ,IFLAG  ,W_DDL  ,FEXT   ,
     6                  MEXT  ,FINT  ,MINT   ,R01    ,NDEB   ,NODGLOB)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE IMP_FRK
      USE IMP_INTM
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "task_c.inc"
#include      "impl1_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      INTEGER NDDL  ,IDDL(*) ,NDOF(*)   ,IKC(*)   ,ITAB(*),IFLAG,
     .        FR_ELEM(*),IAD_ELEM(2,*),INLOC(*),IADK(*),JDIK(*),NODGLOB(*),
     .        NDDLI,IADI(*),JDII(*),ITOK(*),IT,NSREM  ,NSL,W_DDL(*),NDEB
      my_real
     .  DIAG_K(*),DIAG_M(*),LT_K(*),LT_M(*) ,DIAG_I(*),LT_I(*),
     .  U(*),F(*),D(3,*),DR(3,*),FEXT(3,*),MEXT(3,*),FINT(3,*),
     .  R01 ,MINT(3,*),VQ(3,3)
C-----------------------------------------------
c FUNCTION: print-out selected values in function of Ifalg
c
c Note:
c ARGUMENTS:  (I: input, O: output, IO: input * output, W: workspace)
c
c TYPE NAME                FUNCTION
c  I   NDDL,NDOF(N)      - num. of total DOF after condensation; Num of DOF of node N
c  I   IDDL(N)           - ID of DOF (before condensation) num of node N: IDDL(N)+1,NDOF(N)
c  I   IKC(NDDL0)        - different independent dof, IKC()=0-> independent dof
c  I   ITAB(N)           - user's node id
c  I   IADK(NDDL+1),JDIK(NNZ)-indices of assemblaged [K] of compressed format
c  I   DIAG_K(NDDL),LT_K(NNZ)-diag_[K] and compressed non zero strick trianluar [K]
c  I   IADM(NDDL+1),JDIM(NNZ)-same than [K], [M]: preconditioner matrix used for PCG only
c  I   DIAG_M(NDDL),LT_M(NNZ)-
c  I   IADI(NDDLI+1),JDII(NNZI)-indices of local [K_i] of contact spring
c  I   ITOK(NDDLI),DIAG_I(NDDL),LT_I(NNZ)- indice from local to glocal [K]
c  I   NSREM ,NSL        -remote SECONDARY and local communated SECONDARY node number (due to // contact)
c  I   U(NDDL),F(NDDL)   - U not available, F-> force Residual {Fext}-{Fint}
c  I   IT                -nonlinear iteration number
c  I   D,DR(3,NUMNOD)    -nodal displacement and rotation
c  I   IFLAG             -print-out options ,see below
c  I   W_DDL             -flag of physical presence of the boundary dof of diff. domains //
c  I   FEXT,MEXT(3,NUMNOD)- external nodal forces and moments
c  I   FINT,MINT(3,NUMNOD)- internal nodal forces and moments
c  I   R01                -force residual norm
c  I   Ndeb               begin of debugging No of cycle.
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
Ctmp +3
      INTEGER i,j,N,ID,ND,IDDLM(NUMNOD),NKC,IDF,nnod,nk,iad,iad2,id2,
     .        IDDL_FRONT(NDDL),ID2N(NUMNOD),NKFRONT,INOD,K,NN,II,
     .        IDDL_FRONT1(NSPMD,NDDL),ITAG(2,NSPMD),INDEX,ILOC,JJ,KK
      CHARACTER CHIF
      CHARACTER*9 FILNAME
      my_real
     .  s_max,xl,yl,zl
C------iflag=1 ->U,F;iflag=2 ->+ [ki];iflag=3 ->+ [k];--iflag=4 ->+[m];
        IDF = ispmd+11
        WRITE(CHIF,'(I1)')ispmd
        FILNAME='DEB'//CHIF//'.TMP'
        OPEN(UNIT=IDF,FILE=FILNAME,STATUS='UNKNOWN',FORM='FORMATTED')
        write(IDF,*)'NCYCLE,IT,NUMNOD,NDDL=',NCYCLE,IT,NUMNOD,NDDL
        write(IDF,*)'NDDLI,NSREM,NSL,IMCONV,NDEB=', NDDLI,NSREM ,NSL,
     .                IMCONV,NDEB
         if (IMCONV==-1.and.(NSREM +NSL)==0) then
           return
         end if
        write(IDF,*)'R01=',R01
c        write(IDF,*)'nddlfr=',nddlfr
       if (NCYCLE==(NDEB+1).AND.IT==0.AND.IMCONV>=0) then
        NKC=0
       DO N =1,NUMNOD
        I=INLOC(N)
        IDDLM(I)=IDDL(I)-NKC
        DO J=1,NDOF(I)
         ND = IDDL(I)+J
         IF (IKC(ND)/=0) NKC = NKC + 1
        ENDDO
c       if (NDOF(I)/=0)
        write(IDF,*)'I,ITAB,NDOF,IDDLM=',I,ITAB(I),NDOF(I),
     .                IDDLM(I),NODGLOB(I)
       ENDDO
       endif
c        if (NSPMD==1) then
c         I = 849965
        II=0
        S_MAX=ZERO
        NN =0
        K=0
        NKC=0
       DO N =1,NUMNOD
        I=INLOC(N)
        IDDLM(I)=IDDL(I)-NKC
        JJ=0
        DO J=1,NDOF(I)
         ND = IDDL(I)+J
         IF (IKC(ND)/=0) THEN
          NKC = NKC + 1
         ELSE
          JJ = JJ + 1
          ID =IDDLM(I) + JJ
          ID2N(ID)=I
              write(IDF,*)'DIAG_K,F,N,id=',DIAG_K(ID),F(ID),ITAB(I),id
              if (abs(f(id))>S_MAX) THEN
               S_MAX= abs(f(id))
               II = ID
           NN = I
           K=J
              endif
         END IF
        ENDDO
       ENDDO
             if (nn>0) write(IDF,*)'MAX_F,N,J=',F(II),ITAB(NN),K      
c        DO N =1,NDDL
c         I = ITOK(N)
c         I = N
c         write(IDF,*),'NC,DIAG_k,DIAG_M=',
c     .      IADK(I+1)-IADK(I),DIAG_K(I),DIAG_M(I)
c         write(IDF,*)'DIAG_K,F(I)=',DIAG_K(I),F(I),I
c         if (abs(f(i))>S_MAX) THEN
c         S_MAX= abs(f(i))
c         II = I
c         endif
c        ENDDO
c         write(IDF,*)'MAX_F=',F(II),II
       if (iflag>1) then
        DO N =1,NUMNOD
         I=INLOC(N)
             write(IDF,*)'FEXT,MEXT,I,ITAB=',I,ITAB(I)
             write(IDF,*)FEXT(1,I),FEXT(2,I),FEXT(3,I)
             IF (IRODDL/=0)write(IDF,*)MEXT(1,I),MEXT(2,I),MEXT(3,I)
        ENDDO
        DO N =1,NUMNOD
         I=INLOC(N)
             write(IDF,*)'FINT,MINT,I,ITAB=',I,ITAB(I)
             write(IDF,*)FINT(1,I),FINT(2,I),FINT(3,I)
c         IF (IRODDL/=0)write(IDF,*)MINT(1,I),MINT(2,I),MINT(3,I)
c         XL = VQ(1,1)*FINT(1,I)+ VQ(1,2)*FINT(2,I)+VQ(1,3)*FINT(3,I)
c         YL = VQ(2,1)*FINT(1,I)+ VQ(2,2)*FINT(2,I)+VQ(2,3)*FINT(3,I)
c         ZL = VQ(3,1)*FINT(1,I)+ VQ(3,2)*FINT(2,I)+VQ(3,3)*FINT(3,I)
c         write(IDF,*)'FINT,local=',I,ITAB(I)
c         write(IDF,*)XL,YL,ZL
        ENDDO
       endif
       if (iflag>=1) then
        DO N =1,NUMNOD
         I=INLOC(N)
c          if (NDOF(I)/=0) then
             write(IDF,*)'D,DR,I,ITAB=',I,ITAB(I)
             write(IDF,*)D(1,I),D(2,I),D(3,I)
             IF (IRODDL/=0)write(IDF,*)DR(1,I),DR(2,I),DR(3,I)
c          end if !(NDOF(I)/=0) then
        ENDDO
       endif
       if (NSPMD>1) then
C
       IF (INTP_D>0) THEN
         write(IDF,*)'NDDL_SL,NDDL_SI=',NDDL_SL,NDDL_SI 
        DO I=1,NSL
         N=ISL(I)
         write (IDF,*)'NS,I=',N,ITAB(N),I
        END DO
        DO I=1,NDDL_SL
         ID=IDDL_SL(I)
         write(IDF,*)'ID,DIAG_SL=',ID,DIAG_SL(I)
        END DO
        DO I=1,NDDL_SL
         DO J = IAD_SS(I), IAD_SS(I+1)-1
          write(IDF,*)'LT_SL,NJ,J=',LT_SL(J),JDI_SL(J),J
         END DO
        END DO
        write (IDF,*)'NDDL_SI=',NDDL_SI
         DO I=1,NDDL_SI
         DO J = IAD_SI(I), IAD_SI(I+1)-1
          write(IDF,*)'LT_SI,NJ,J=',LT_SI(J),JDI_SI(J),J
         END DO
        END DO
       ELSE
        DO I=1,NSL
         N=ISL(I)
         DO J=1,MIN(3,NDOF(N))
          ID = IDDSL(J,I)
          IF (ID>0) write(IDF,*)'ID,DIAG_SL=',ID,DIAG_S(J,I)
         END DO
        write (IDF,*)'NS,I=',N,I
        END DO
       END IF
       IAD = 0 
       IAD2 = 0 
       write(IDF,*)'LEN_K,LEN_V=',LEN_K,LEN_V
      DO I =1,NSPMD
       NKC=0
       DO NK=IAD_ELEM(1,I),IAD_ELEM(1,I+1)-1
        N=FR_ELEM(NK)
        ND=0
        write(IDF,*)'N,ITAB,IDDLFR,IP=',N,ITAB(N),IDDLFR(NK),I
        DO J=1,NDOF(N)
         IF (IKC(IDDL(N)+J)<1) THEN
c          ND=ND+1
          ID=IDDLFR(NK)+IAD-NKC+J
          ID2=IDDLFR(NK)+IAD2-NKC+J
          write(IDF,*)
     .   'FR_ID,id2,id2k,NC=',ID,id2,IFR2K(id2),IADFR(ID+1)-IADFR(ID)
         IF (IADFR(ID+1)<IADFR(ID)) write(IDF,*)IADFR(ID+1),IADFR(ID)
         ELSE
          NKC=NKC+1
         ENDIF
        ENDDO
       ENDDO
       IAD = IAD + ND_FR(I) + 1
       IAD2 = IAD2 + ND_FR(I)
      ENDDO
       endif
       if (iflag>=1) then
        write(IDF,*)'[Ki]=',NDDLI
       DO I =1,NDDLI
         N=ID2N(ITOK(I))
         write(IDF,*)'DIAG_I,itok,N=',DIAG_I(I),ITOK(I),ITAB(N)
       ENDDO
       DO I =1,NDDLI
         N=ID2N(ITOK(I))
         write(IDF,*)'NR,I(itok),N=',IADI(I+1)-IADI(I),ITOK(I),ITAB(N)
        DO J=IADI(I),IADI(I+1)-1
         N=ID2N(ITOK(JDII(J)))
         write(IDF,*)'LT_I,_id_NJ,NJ,J=',LT_I(J),ITOK(JDII(J)),ITAB(N),J
        ENDDO
       ENDDO
       endif
       if (iflag>1) then
        write(IDF,*)'LT_[K]=',NDDL
       DO I =1,NDDL
         write(IDF,*)'NR,I=',IADK(I+1)-IADK(I),I
        DO J=IADK(I),IADK(I+1)-1
         write(IDF,*)'LT_K,NJ,J=',LT_K(J),JDIK(J),J
        ENDDO
       ENDDO
       endif
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  PR_MATRIX                     source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|-- calls ---------------
Chd|        IMP_FRK                       share/modules/impbufdef_mod.F 
Chd|====================================================================
      SUBROUTINE PR_MATRIX(NDDL  ,IDDL  ,NDOF   ,IKC   ,ITAB   ,
     1                     DIAG_K,DIAG_M,INLOC  ,FR_ELEM,IAD_ELEM,
     2                     IADK  ,JDIK  ,LT_K   ,LT_M   ,NDDLI  ,
     3                     IADI  ,JDII  ,ITOK   ,DIAG_I ,LT_I   ,
     4                     IFLAG ,it    )
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE IMP_FRK
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "task_c.inc"
#include      "impl1_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      INTEGER NDDL  ,IDDL(*) ,NDOF(*)   ,IKC(*)   ,ITAB(*),IFLAG,
     .        FR_ELEM(*),IAD_ELEM(2,*),INLOC(*),IADK(*),JDIK(*),
     .        NDDLI,IADI(*),JDII(*),ITOK(*),it
      my_real
     .  DIAG_K(*),DIAG_M(*),LT_K(*),LT_M(*) ,DIAG_I(*),LT_I(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
Ctmp +3
      INTEGER i,j,N,ID,ND,IDDLM(NUMNOD),NKC,IDF,nnod,nk,iad,iad2,id2,
     .        NKFRONT,INOD,K,NN,II,INDEX,ILOC,JJ,KK
      CHARACTER CHIF
      CHARACTER*9 FILNAME
      my_real
     .  s_max,xl,yl,zl
C------
        IDF = ispmd+15
        WRITE(CHIF,'(I1)')ispmd
        FILNAME='MAT'//CHIF//'.TMP'
        OPEN(UNIT=IDF,FILE=FILNAME,STATUS='UNKNOWN',FORM='FORMATTED')
        write(IDF,*)'NCYCLE,NUMNOD,NDDL,NDI=',NCYCLE,NUMNOD,NDDL,NDDLI
         if (IMCONV<0) return
c        write(IDF,*)'nddlfr=',nddlfr
       if (NCYCLE==1) then
        NKC=0
       DO N =1,NUMNOD
        I=INLOC(N)
        IDDLM(I)=IDDL(I)-NKC
        DO J=1,NDOF(I)
         ND = IDDL(I)+J
         IF (IKC(ND)/=0) NKC = NKC + 1
        ENDDO
       if (NDOF(I)/=0)
     .  write(IDF,*)'I,ITAB,NDOF,IDDL=',I,ITAB(I),NDOF(I),
     .                IDDL(I)
       ENDDO
       endif
        DO N =1,NDDL
          I = N
c         write(IDF,*),'NC,DIAG_k,DIAG_M=',
c     .      IADK(I+1)-IADK(I),DIAG_K(I),DIAG_M(I)
          write(IDF,*)'DIAG_K,DIAG_M=',DIAG_K(I),DIAG_M(I),I
        ENDDO
       if (NSPMD>1) then
C
       IAD = 0
       IAD2 = 0
       write(IDF,*)'LEN_K,LEN_V=',LEN_K,LEN_V
      DO I =1,NSPMD
       NKC=0
       DO NK=IAD_ELEM(1,I),IAD_ELEM(1,I+1)-1
        N=FR_ELEM(NK)
        ND=0
        write(IDF,*)'N,ITAB,IDDLFR,IP=',N,ITAB(N),IDDLFR(NK),I
        DO J=1,NDOF(N)
         IF (IKC(IDDL(N)+J)<1) THEN
c          ND=ND+1
          ID=IDDLFR(NK)+IAD-NKC+J
          ID2=IDDLFR(NK)+IAD2-NKC+J
          write(IDF,*)
     .   'FR_ID,id2,id2k,NC=',ID,id2,IFR2K(id2),IADFR(ID+1)-IADFR(ID)
         IF (IADFR(ID+1)<IADFR(ID)) write(IDF,*)IADFR(ID+1),IADFR(ID)
         ELSE
          NKC=NKC+1
         ENDIF
        ENDDO
       ENDDO
       IAD = IAD + ND_FR(I) + 1
       IAD2 = IAD2 + ND_FR(I)
      ENDDO
       endif
       if (NDDLI>0.AND.IFLAG>0) then
        write(IDF,*)'[Ki]=',NDDLI
       DO I =1,NDDLI
         write(IDF,*)'DIAG_I,itok=',DIAG_I(I),ITOK(I)
       ENDDO
       DO I =1,NDDLI
         write(IDF,*)'NR,I=',IADI(I+1)-IADI(I),I
        DO J=IADI(I),IADI(I+1)-1
         write(IDF,*)'LT_I,NJ,J=',LT_I(J),ITOK(JDII(J)),J
        ENDDO
       ENDDO
       endif
       if (NDDL>1.and.IFLAG>1) then
        write(IDF,*)'LT_[K]=',NDDL
       DO I =1,NDDL
         write(IDF,*)'NR,I=',IADK(I+1)-IADK(I),I
        DO J=IADK(I),IADK(I+1)-1
         write(IDF,*)'LT_K,NJ,J=',LT_K(J),JDIK(J),J
        ENDDO
       ENDDO
       if (IFLAG>1) then
        write(IDF,*)'LT_[M]=',NDDL
       DO I =1,NDDL
         write(IDF,*)'NR,I=',IADK(I+1)-IADK(I),I
        DO J=IADK(I),IADK(I+1)-1
         write(IDF,*)'LT_M,NJ,J=',LT_M(J),JDIK(J),J
        ENDDO
       ENDDO
       endif !(IFLAG>1) then
       endif
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  PR_SOLNFO                     source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        SPMD_MAX_F                    source/mpi/implicit/imp_spmd.F
Chd|        IMP_FRK                       share/modules/impbufdef_mod.F 
Chd|        IMP_INTM                      share/modules/imp_intm.F      
Chd|====================================================================
      SUBROUTINE PR_SOLNFO(NDDL  ,IDDL  ,NDOF   ,IKC   ,ITAB   ,
     1                  DIAG_K,DIAG_M,INLOC  ,FR_ELEM,IAD_ELEM,
     2                  IADK  ,JDIK  ,LT_K   ,LT_M   ,NDDLI  ,
     3                  IADI  ,JDII  ,ITOK   ,DIAG_I ,LT_I   ,
     4                  U     ,F     ,IT     ,NSREM  ,NSL    ,
     5                  D     ,DR    ,IFLAG  ,W_DDL  ,FEXT   ,
     6                  MEXT  ,FINT  ,MINT   ,R01    ,NDEB   ,
     7                  R_IMP ,I_IMP ,DD     ,DDR)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE IMP_FRK
      USE IMP_INTM
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "com08_c.inc"
#include      "task_c.inc"
#include      "impl1_c.inc"
#include      "impl2_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      INTEGER NDDL  ,IDDL(*) ,NDOF(*)   ,IKC(*)   ,ITAB(*),IFLAG,
     .        FR_ELEM(*),IAD_ELEM(2,*),INLOC(*),IADK(*),JDIK(*),
     .        NDDLI,IADI(*),JDII(*),ITOK(*),IT,NSREM  ,NSL,W_DDL(*),
     .        NDEB,I_IMP(*)
      my_real
     .  DIAG_K(*),DIAG_M(*),LT_K(*),LT_M(*) ,DIAG_I(*),LT_I(*),
     .  U(*),F(*),D(3,*),DR(3,*),FEXT(3,*),MEXT(3,*),FINT(3,*),
     .  R01 ,MINT(3,*),VQ(3,3),R_IMP(*),DD(3,*),DDR(3,*)
C-----------------------------------------------
c FUNCTION: print-out solver info such as maximum residual, relative residuals, line-search coeff, tolerance
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,N,ID,ND,IDDLM(NUMNOD),NKC,IDF,NNOD,NK,IAD,IAD2,
     .        IDDL_FRONT(NDDL),ID2N(NUMNOD),NKFRONT,INOD,ID2,CUMUL_IT,
     .        IDDL_FRONT1(NSPMD,NDDL),ITAG(2,NSPMD),INDEX,ILOC,JJ,KK,
     .        K,K2,K3,KR,K2R,K3R,NN,NN2,NN3,NNR,NN2R,NN3R,II,IIR,II2,
     .        ITABMAX,IRTABMAX,ITABMAX2,IRTABMAX2,ITABMAX3,IRTABMAX3
      my_real
     .  F_MAX,FR_MAX,D_MAX,DR_MAX,DD_MAX,DDR_MAX,
     .  FMAX,FRMAX,DMAX,DRMAX,DDMAX,DDRMAX,TOLE,TOLF,TOLU
      CHARACTER NODEID*10,FILNAM*100
c       if (IMCONV==-1.and.(NSREM +NSL)==0) then
c         return
c       end if
c       if (NCYCLE==(NDEB+1).AND.IT==0.AND.IMCONV>=0) then
c        NKC=0
c       DO N =1,NUMNOD
c        I=INLOC(N)
c        IDDLM(I)=IDDL(I)-NKC
c        DO J=1,NDOF(I)
c         ND = IDDL(I)+J
c         IF (IKC(ND)/=0) NKC = NKC + 1
c        ENDDO
c       ENDDO
c       endif
        II=0
        IIR=0
        F_MAX=ZERO
        FR_MAX=ZERO
        D_MAX=ZERO
        DR_MAX=ZERO
        DD_MAX=ZERO
        DDR_MAX=ZERO
        FMAX=ZERO
        FRMAX=ZERO
        DMAX=ZERO
        DRMAX=ZERO
        DDMAX=ZERO
        DDRMAX=ZERO
        NN=0
        NN2=0
        NN3=0
        K=0
        K2=0
        K3=0
        NNR=0
        NN2R=0
        NN3R=0
        KR=0
        K2R=0
        K3R=0
        NKC=0
       DO N =1,NUMNOD
        I=INLOC(N)
        IDDLM(I)=IDDL(I)-NKC
        JJ=0
        DO J=1,NDOF(I)
         ND = IDDL(I)+J
         IF (IKC(ND)/=0) THEN
          NKC = NKC + 1
         ELSE
          JJ = JJ + 1
          ID =IDDLM(I) + JJ
          ID2 = IDDLM(I)
c          ID2N(ID)=I
          IF (J < 4) THEN
            IF (abs(F(ID))>F_MAX) THEN
              F_MAX= abs(F(ID))
              II = ID
              NN = I
              K = J
            ENDIF
            IF (abs(D(J,I))>D_MAX) THEN
                  D_MAX= abs(D(J,I))
              NN2 = I
              K2 = J
                ENDIF
            IF (abs(DD(J,I))>DD_MAX) THEN
                  DD_MAX= abs(DD(J,I))
              NN3 = I
              K3 = J
                ENDIF
          ELSE
            IF (abs(F(ID))>FR_MAX) THEN
             FR_MAX= abs(F(ID))
             IIR = ID
             NNR = I
             KR = J
            ENDIF 
            IF (abs(DR(J-3,I))>DR_MAX) THEN
                  DR_MAX= abs(DR(J-3,I))
              NN2R = I
              K2R = J
                ENDIF  
            IF (abs(DDR(J-3,I))>DDR_MAX) THEN
                  DDR_MAX= abs(DDR(J-3,I))
              NN3R = I
              K3R = J
                ENDIF             
          ENDIF
         ENDIF
        ENDDO
       ENDDO
       IF (II /= 0) FMAX = F(II)
       ITABMAX = ITAB(NN)
       IF (IIR /= 0) FRMAX = F(IIR)
       IRTABMAX = ITAB(NNR)
       IF (NN2 /= 0) DMAX = D(K2,NN2)
       ITABMAX2 = ITAB(NN2)
       IF (NN2R /= 0) DRMAX = DR(K2R-3,NN2R)
       IRTABMAX2 = ITAB(NN2R)  
       IF (NN3 /= 0) DDMAX = DD(K3,NN3)
       ITABMAX3 = ITAB(NN3)
       IF (NN3R /= 0) DDRMAX = DDR(K3R-3,NN3R)
       IRTABMAX3 = ITAB(NN3R)              
c      Compute maximum value F(II) with several processes in SPMD
       IF (NSPMD>1) THEN
         CALL SPMD_MAX_F(FMAX,ITABMAX,K)
         CALL SPMD_MAX_F(DMAX,ITABMAX2,K2)
         CALL SPMD_MAX_F(DDMAX,ITABMAX3,K3)
         CALL SPMD_MAX_F(FRMAX,IRTABMAX,KR)
         CALL SPMD_MAX_F(DRMAX,IRTABMAX2,K2R)
         CALL SPMD_MAX_F(DDRMAX,IRTABMAX3,K3R)
       END IF
c      Write solver information
       IF (ISPMD==0) THEN
         IF (IT == ZERO) THEN
          WRITE(ISOLINFO,1667) NCYCLE       
         ENDIF
         WRITE(ISOLINFO,1060) IT 
         WRITE(ISOLINFO,1066) FMAX,ITABMAX,K
         WRITE(ISOLINFO,1064) DMAX,ITABMAX2,K2
         WRITE(ISOLINFO,1062) DDMAX,ITABMAX3,K3
         WRITE(ISOLINFO,1065) FRMAX,IRTABMAX,KR
         WRITE(ISOLINFO,1063) DRMAX,IRTABMAX2,K2R
         WRITE(ISOLINFO,1061) DDRMAX,IRTABMAX3,K3R
         WRITE (NODEID,'(I10)') ITABMAX
         CUMUL_IT = I_IMP(1)+IT
c        Write monitor file         
         IF (K==0) THEN
           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxResidualForce  ',NODEID//'  ',FMAX 
         ELSEIF (K==1) THEN
           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxResidualForce  ',NODEID//'_X',FMAX 
         ELSEIF (K==2) THEN
           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxResidualForce  ',NODEID//'_Y',FMAX 
         ELSEIF (K==3) THEN
           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxResidualForce  ',NODEID//'_Z',FMAX   
         ENDIF
c         WRITE (NODEID,'(I10)') ITABMAX2
c         IF (K2==0) THEN
c           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxIncrementDisp  ',NODEID//'  ',DMAX 
c         ELSEIF (K2==1) THEN
c           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxIncrementDisp  ',NODEID//'_X',DMAX 
c         ELSEIF (K2==2) THEN
c           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxIncrementDisp  ',NODEID//'_Y',DMAX 
c         ELSEIF (K2==3) THEN
c           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxIncrementDisp  ',NODEID//'_Z',DMAX   
c         ENDIF 
         WRITE (NODEID,'(I10)') ITABMAX3
         IF (K3==0) THEN
           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxCorrectionDisp ',NODEID//'  ',DDMAX 
         ELSEIF (K3==1) THEN
           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxCorrectionDisp ',NODEID//'_X',DDMAX 
         ELSEIF (K3==2) THEN
           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxCorrectionDisp ',NODEID//'_Y',DDMAX 
         ELSEIF (K3==3) THEN
           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxCorrectionDisp ',NODEID//'_Z',DDMAX   
         ENDIF  
         WRITE (NODEID,'(I10)') IRTABMAX
         IF (KR==0) THEN
           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxResidualMoment ',NODEID//'  ',FRMAX 
         ELSEIF (KR==4) THEN
           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxResidualMoment ',NODEID//'_X',FRMAX 
         ELSEIF (KR==5) THEN
           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxResidualMoment ',NODEID//'_Y',FRMAX 
         ELSEIF (KR==6) THEN
           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxResidualMoment ',NODEID//'_Z',FRMAX   
         ENDIF
c         WRITE (NODEID,'(I10)') IRTABMAX2
c         IF (K2R==0) THEN
c           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxIncrementRota  ',NODEID//'  ',DRMAX 
c         ELSEIF (K2R==4) THEN
c           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxIncrementRota  ',NODEID//'_X',DRMAX 
c         ELSEIF (K2R==5) THEN
c           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxIncrementRota  ',NODEID//'_Y',DRMAX 
c         ELSEIF (K2R==6) THEN
c           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxIncrementRota  ',NODEID//'_Z',DRMAX   
c         ENDIF 
         WRITE (NODEID,'(I10)') IRTABMAX3
         IF (K3R==0) THEN
           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxCorrectionRota ',NODEID//'  ',DDRMAX 
         ELSEIF (K3R==4) THEN
           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxCorrectionRota ',NODEID//'_X',DDRMAX 
         ELSEIF (K3R==5) THEN
           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxCorrectionRota ',NODEID//'_Y',DDRMAX 
         ELSEIF (K3R==6) THEN
           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxCorrectionRota ',NODEID//'_Z',DDRMAX   
         ENDIF  
         WRITE(NODEID,'(I10)') 0
         WRITE(ISOLMNTR,1160) CUMUL_IT,0,' NormResidualDisp  ',NODEID//'  ',R_IMP(20) 
         WRITE(ISOLMNTR,1160) CUMUL_IT,0,' NormResidualForce ',NODEID//'  ',R_IMP(21) 
         WRITE(ISOLMNTR,1160) CUMUL_IT,0,' NormResidualEnergy',NODEID//'  ',R_IMP(22) 
         WRITE(ISOLMNTR,1160) CUMUL_IT,0,' DimContactMatrix  ',NODEID//'  ',FLOAT(I_IMP(13))
         WRITE(ISOLMNTR,1160) CUMUL_IT,0,' TimeStep          ',NODEID//'  ',DT2
C         CALL MY_FLUSH(ISOLMNTR)
         CALL FLUSH(ISOLMNTR)
         IF (IMCONV == 1) THEN
           IF (NITOL == 1) THEN
             WRITE(ISOLINFO,1067)
           ELSE IF (NITOL == 2) THEN
             WRITE(ISOLINFO,1069) 
           ELSE IF (NITOL == 3) THEN
             WRITE(ISOLINFO,1071)              
           ELSE IF (NITOL == 12) THEN
             WRITE(ISOLINFO,1073)              
           ELSE IF (NITOL == 13) THEN
             WRITE(ISOLINFO,1075)
           ELSE IF (NITOL == 23) THEN
             WRITE(ISOLINFO,1077)            
           ELSE IF (NITOL == 123) THEN
             WRITE(ISOLINFO,1079)           
           END IF
         ELSE IF (IMCONV == -2) THEN
           IF (NITOL == 1) THEN
             WRITE(ISOLINFO,1068)
           ELSE IF (NITOL == 2) THEN
             WRITE(ISOLINFO,1070) 
           ELSE IF (NITOL == 3) THEN
             WRITE(ISOLINFO,1072)  
           ELSE IF (NITOL == 12) THEN
             WRITE(ISOLINFO,1074) 
           ELSE IF (NITOL == 13) THEN
             WRITE(ISOLINFO,1076)
           ELSE IF (NITOL == 23) THEN
             WRITE(ISOLINFO,1078) 
           ELSE IF (NITOL == 123) THEN
             WRITE(ISOLINFO,1080)             
           END IF
         ENDIF
         IF (NITOL == 1) THEN
             TOLE = N_TOL
             TOLF = EM02
             TOLU = EM02
           ELSE IF (NITOL == 2) THEN
             TOLE = EM03
             TOLF = N_TOL
             TOLU = EM02
           ELSE IF (NITOL == 3) THEN
             TOLE = EM03
             TOLF = EM02
             TOLU = N_TOL             
           ELSE IF (NITOL == 12) THEN
             TOLE = N_TOLE
             TOLF = N_TOLF
             TOLU = EM02             
           ELSE IF (NITOL == 13) THEN
             TOLE = N_TOLE
             TOLF = EM02
             TOLU = N_TOLU
           ELSE IF (NITOL == 23) THEN
             TOLE = EM03
             TOLF = N_TOLF
             TOLU = N_TOLU             
           ELSE IF (NITOL == 123) THEN
             TOLE = N_TOLE
             TOLF = N_TOLF
             TOLU = N_TOLU             
         END IF
         IF (IMCONV == -1) THEN
c         Nothing since line search not ended
         ELSEIF (IMCONV == 0) THEN
          WRITE(ISOLHIST,1666)CUMUL_IT+1,NCYCLE,IT,R_IMP(20),
     .        R_IMP(21),R_IMP(22),TOLE,TOLF,TOLU,
     .        ZERO,ZERO,TT,R_IMP(9)
        ELSEIF (IMCONV == 1) THEN
c         Converged step
        IF (IDTC==3) THEN
         WRITE(ISOLHIST,1668)CUMUL_IT+1,NCYCLE,IT,R_IMP(20),
     .        R_IMP(21),R_IMP(22),TOLE,TOLF,TOLU,
     .        ZERO,ZERO,TT,R_IMP(9),TT,R_IMP(24)
         WRITE(ISOLHIST,1668)CUMUL_IT+1,NCYCLE,IT,R_IMP(20),
     .        R_IMP(21),R_IMP(22),TOLE,TOLF,TOLU,
     .        ONE,ZERO,TT,R_IMP(9),TT,R_IMP(24)
         WRITE(ISOLHIST,1668)CUMUL_IT+1,NCYCLE,IT,R_IMP(20),
     .        R_IMP(21),R_IMP(22),TOLE,TOLF,TOLU,
     .        ZERO,ZERO,TT,R_IMP(9),TT,R_IMP(24)  
        ELSE
         WRITE(ISOLHIST,1666)CUMUL_IT+1,NCYCLE,IT,R_IMP(20),
     .        R_IMP(21),R_IMP(22),TOLE,TOLF,TOLU,
     .        ZERO,ZERO,TT,R_IMP(9)
         WRITE(ISOLHIST,1666)CUMUL_IT+1,NCYCLE,IT,R_IMP(20),
     .        R_IMP(21),R_IMP(22),TOLE,TOLF,TOLU,
     .        ONE,ZERO,TT,R_IMP(9)
         WRITE(ISOLHIST,1666)CUMUL_IT+1,NCYCLE,IT,R_IMP(20),
     .        R_IMP(21),R_IMP(22),TOLE,TOLF,TOLU,
     .        ZERO,ZERO,TT,R_IMP(9)   
        ENDIF    
c         Write .progress file
          REWIND(ISOLPGRS)
          WRITE(ISOLPGRS,'(I4)') CUMUL_IT          
          WRITE(ISOLPGRS,'(E11.4)') TT
          WRITE(ISOLPGRS,'(I4)') nint(TT/TSTOP*HUNDRED)
          WRITE(ISOLPGRS,'(I4)') 0
          WRITE(ISOLPGRS,'(I4)') 0
          CALL FLUSH(ISOLPGRS)       
        ELSEIF (IMCONV == -2) THEN
c         Diverged step         
         WRITE(ISOLHIST,1666)CUMUL_IT+1,NCYCLE,IT,R_IMP(20),
     .        R_IMP(21),R_IMP(22),TOLE,TOLF,TOLU,
     .        ZERO,ZERO,TT,R_IMP(9)
         WRITE(ISOLHIST,1666)CUMUL_IT+1,NCYCLE,IT,R_IMP(20),
     .        R_IMP(21),R_IMP(22),TOLE,TOLF,TOLU,
     .        ZERO,ONE,TT,R_IMP(9)
         WRITE(ISOLHIST,1666)CUMUL_IT+1,NCYCLE,IT,R_IMP(20),
     .        R_IMP(21),R_IMP(22),TOLE,TOLF,TOLU,
     .        ZERO,ZERO,TT,R_IMP(9)         
        ENDIF  
      ENDIF
1060  FORMAT('       ITERATION',I4)       
1061  FORMAT('           LARGEST CORRECTION ROTA.  ',E11.4,
     .       '   AT NODE  ',I10,'   DOF  ',I4)         
1062  FORMAT('           LARGEST CORRECTION DISP.  ',E11.4,
     .       '   AT NODE  ',I10,'   DOF  ',I4)         
1063  FORMAT('           LARGEST INCREMENT ROTA.   ',E11.4,
     .       '   AT NODE  ',I10,'   DOF  ',I4)         
1064  FORMAT('           LARGEST INCREMENT DISP.   ',E11.4,
     .       '   AT NODE  ',I10,'   DOF  ',I4)         
1065  FORMAT('           LARGEST RESIDUAL MOMENT   ',E11.4,
     .       '   AT NODE  ',I10,'   DOF  ',I4)       
1066  FORMAT('           LARGEST RESIDUAL FORCE    ',E11.4,
     .       '   AT NODE  ',I10,'   DOF  ',I4) 
1067  FORMAT('       ACCEPTED EQUILIBRIUM BASED ON SMALL RESIDUAL ENERGY')
1068  FORMAT('       REJECTED EQUILIBRIUM BASED ON SMALL RESIDUAL ENERGY') 
1069  FORMAT('       ACCEPTED EQUILIBRIUM BASED ON SMALL RESIDUAL FORCE')
1070  FORMAT('       REJECTED EQUILIBRIUM BASED ON SMALL RESIDUAL FORCE') 
1071  FORMAT('       ACCEPTED EQUILIBRIUM BASED ON SMALL RESIDUAL DISP.')
1072  FORMAT('       REJECTED EQUILIBRIUM BASED ON SMALL RESIDUAL DISP.') 
1073  FORMAT('       ACCEPTED EQUILIBRIUM BASED ON SMALL RESIDUAL ENERGY AND FORCE')
1074  FORMAT('       REJECTED EQUILIBRIUM BASED ON SMALL RESIDUAL ENERGY AND FORCE')
1075  FORMAT('       ACCEPTED EQUILIBRIUM BASED ON SMALL RESIDUAL ENERGY AND DISP.')
1076  FORMAT('       REJECTED EQUILIBRIUM BASED ON SMALL RESIDUAL ENERGY AND DISP.')  
1077  FORMAT('       ACCEPTED EQUILIBRIUM BASED ON SMALL RESIDUAL FORCE AND DISP.')
1078  FORMAT('       REJECTED EQUILIBRIUM BASED ON SMALL RESIDUAL FORCE AND DISP.') 
1079  FORMAT('       ACCEPTED EQUILIBRIUM BASED ON SMALL RESIDUAL ENERGY, FORCE AND DISP.')
1080  FORMAT('       REJECTED EQUILIBRIUM BASED ON SMALL RESIDUAL ENERGY, FORCE AND DISP.')
1666  FORMAT(I10,',',I10,',',I10,',',E10.2,',',E10.2,',',E10.2,',',E10.2,',',E10.2,',',E10.2,',',E10.2,
     .       ',',E10.2,',',E10.2,',',E10.2)
1667  FORMAT('   * CYCLE',I6)  
1668  FORMAT(I10,',',I10,',',I10,',',E10.2,',',E10.2,',',E10.2,',',E10.2,',',E10.2,',',E10.2,',',E10.2,
     .       ',',E10.2,',',E10.2,',',E10.2,',',E10.2,',',E10.2)
1160  FORMAT(I6,I6,A19,A12,E12.4)
C------------------------------------------
      RETURN
      END
    
Chd|====================================================================
Chd|  WRITE_TPL_FILE                source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        RADIOSS2                      source/engine/radioss2.F      
Chd|-- calls ---------------
Chd|====================================================================
      SUBROUTINE WRITE_TPL_FILE(FILNAM,IOFF1,IOFF2,IOFF3)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "impl1_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      CHARACTER(*) FILNAM,IOFF1,IOFF2,IOFF3
      my_real
     .  R01
C-----------------------------------------------
c FUNCTION: print-out tcp file
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J
      my_real
     .  F_MAX
C-----------------------------------------------     
      WRITE(ISOLTPL,1000) FILNAM
      WRITE(ISOLTPL,1001)
      WRITE(ISOLTPL,1002) IOFF2,1,4,1,3,4,1,'Residual force',1
     .   ,'Residual force','Residual force','Residual force'
     .   ,'Residual force','Residual force','Residual force'
      WRITE(ISOLTPL,1002) IOFF2,1,4,1,0,4,1,'Tolerance force',1
     .   ,'Tolerance force','Tolerance force','Tolerance force'
     .   ,'Tolerance force','Tolerance force','Tolerance force'      
      WRITE(ISOLTPL,1002) IOFF3,1,46,1,3,46,1,'Residual disp.',1
     .   ,'Residual disp.','Residual disp.','Residual disp.'
     .   ,'Residual disp.','Residual disp.','Residual disp.'
      WRITE(ISOLTPL,1002) IOFF3,1,46,1,0,4,1,'Tolerance disp.',1
     .   ,'Tolerance disp.','Tolerance disp.','Tolerance disp.'
     .   ,'Tolerance disp.','Tolerance disp.','Tolerance disp.'   
      WRITE(ISOLTPL,1002) IOFF1,1,0,1,3,0,1,'Residual energy',1
     .   ,'Residual energy','Residual energy','Residual energy'
     .   ,'Residual energy','Residual energy','Residual energy'
      WRITE(ISOLTPL,1002) IOFF1,1,0,1,0,4,1,'Tolerance energy',1
     .   ,'Tolerance energy','Tolerance energy','Tolerance energy'
     .   ,'Tolerance energy','Tolerance energy','Tolerance energy'    
      WRITE(ISOLTPL,1002) 'On',1,55,1,0,55,1,'Converged step',2
     .   ,'Converged step','Converged step','Converged step'
     .   ,'Converged step','Converged step','Converged step'   
      WRITE(ISOLTPL,1002) 'On',1,2,1,0,2,1,'Diverged step',2
     .   ,'Diverged step','Diverged step','Diverged step'
     .   ,'Diverged step','Diverged step','Diverged step'    
      WRITE(ISOLTPL,1003)
      WRITE(ISOLTPL,1004) 2,2,2,'Cumulative iterations','Line search coeff'
      WRITE(ISOLTPL,1002) 'On',1,50,1,3,50,1,'Line search coefficient',1
     .   ,'Line search coefficient','Line search coefficient','Line search coefficient'
     .   ,'Line search coefficient','Line search coefficient','Line search coefficient'  
      WRITE(ISOLTPL,1003)
      IF (IDTC==3) THEN
      WRITE(ISOLTPL,1004) 3,3,3,'Arc length','Load factor'
      WRITE(ISOLTPL,1006) 'On',1,27,1,3,27,1,'Load factor',1
     .   ,'Load factor','Load factor','Load factor'
     .   ,'Load factor','Load factor','Load factor'      
      ELSE
      WRITE(ISOLTPL,1004) 3,3,3,'Cumulative iterations','Time (s)'
      WRITE(ISOLTPL,1002) 'On',1,27,1,3,27,1,'Time',1
     .   ,'Time','Time','Time'
     .   ,'Time','Time','Time'
      ENDIF
      WRITE(ISOLTPL,1005)
1000  FORMAT('    *BeginPage() // Page 1'/
     .       '        *Title("',A,'", On)'/
     .       '        *TitleFont("Arial", 1, 0, 12)'/
     .       '        *Layout(9)'/
c     .       '        *BeginAnimator(Transient)'/
c     .       '            *CurrentTime(Undeformed)'/
c     .       '            *StartTime(0,0000000)'/
c     .       '            *EndTime(1,0000000)'/
c     .       '            *Increment(Forward, Frame, 1, BounceOff)'/
c     .       '        *EndAnimator()'/
     .       '        *WindowIDs(191, 192, 193)'
     .       )    
1001  FORMAT('        *ExportFormat("PNG")'/
     .       '        *BeginPlot()'/
     .       '            *PlotType(0)'/
     .       '            *BeginPlotHeader(On)'/
     .       '                *PrimaryFont("Arial", 0, 0, 14)'/
     .       '                *SecondaryFont("Arial", 0, 0, 10)'/
     .       '                *TertiaryFont("Arial", 0, 0, 10)'/
     .       '                *Color(0)'/
     .       '                *Text("Relative residuals")'/
     .       '                *HeaderAlignment(2)'/
     .       '            *EndPlotHeader()'/
     .       '            *BeginPlotFooter(Off)'/
     .       '                *PrimaryFont("Arial", 0, 0, 10)'/
     .       '                *SecondaryFont("Arial", 0, 0, 10)'/
     .       '                *TertiaryFont("Arial", 0, 0, 10)'/
     .       '                *Color(0)'/
     .       '                *Text("{p1w1c1.y.HWRequest} - {p1w1c1.y.HWComponent}")'/
     .       '                *FooterAlignment(2)'/
     .       '            *EndPlotFooter()'/
     .       '            *BeginLegend(On)'/
     .       '                *Font("Arial", 0, 0, 8)'/
     .       '                *BorderWidth(1)'/
     .       '                *Color(0)'/
     .       '                *Leader(Left)'/
     .       '                *Location(BELOW)'/
     .       '                *AutoPosition(False)'/
     .       '                *Reversed(no)'/
     .       '            *EndLegend()'/
     .       '            *UniformAspectRatio(0)'/
     .       '            *FrameColor(66)'/
     .       '            *BackgroundColor(1)'/
     .       '            *GridLineColor(9)'/
     .       '            *ZeroLineColor(0)'/
     .       '            *BeginAxis(X, "Primary", on)'/
     .       '                *Label("Cumulative iterations")'/
     .       '                *Scale(Linear)'/
     .       '                *TicMethod(Increment)'/
     .       '                *Min(0)'/
     .       '                *Max(1)'/
     .       '                *Format(Auto)'/
     .       '                *Precision(5)'/
     .       '                *Increment(10)'/
     .       '                *Grids(1)'/
     .       '                *Color(67)'/
     .       '                *AutoFit(TRUE)'/
     .       '                *LabelFont("Arial", 0, 0, 10)'/
     .       '                *TicsFont("Arial", 0, 0, 8)'/
     .       '                *FitRange(FALSE)'/
     .       '            *EndAxis()'/
     .       '            *BeginAxis(Y, "Primary", on)'/
     .       '                *Label("Relative residual")'/
     .       '                *Scale(Log)'/
     .       '                *TicMethod(PerAxis)'/
     .       '                *Min(0)'/
     .       '                *Max(1)'/
     .       '                *Format(Auto)'/
     .       '                *Precision(4)'/
     .       '                *TicsPerDecade(1)'/
     .       '                *GridsPerDecade(1)'/
     .       '                *Color(67)'/
     .       '                *AutoFit(TRUE)'/
     .       '                *LabelFont("Arial", 0, 0, 10)'/
     .       '                *TicsFont("Arial", 0, 0, 8)'/
     .       '                *FitRange(FALSE)'/
     .       '            *EndAxis()'/
     .       '            *BeginAxis(Y, "Y1", on)'/
     .       '                *Label("")'/
     .       '                *Scale(Linear)'/
     .       '                *TicMethod(PerAxis)'/
     .       '                *Min(0)'/
     .       '                *Max(1)'/
     .       '                *Format(Auto)'/
     .       '                *Precision(0)'/
     .       '                *Tics(2)'/
     .       '                *Grids(2)'/
     .       '                *Color(67)'/
     .       '                *AutoFit(TRUE)'/
     .       '                *LabelFont("Arial", 0, 0, 8)'/
     .       '                *TicsFont("Arial", 0, 0, 8)'/
     .       '                *FitRange(FALSE)'/
     .       '            *EndAxis()'     
     .       )
1002  FORMAT('            *BeginCurve(',A,', "{y.HWComponent}")'/
     .       '                *Line(',I2,',',I2,',',I2,')'/
     .       '                *Symbol(',I2,',',I2,',',I2,')'/
     .       '                *Shade(False)'/
     .       '                *Bar(0, 0, 2)'/
     .       '                *ShowInLegend(True)'/
     .       '                *LayerNumber(31)'/
     .       '                *BeginVector(Y, File)'/
     .       '                    *Filename(PLOT_FILE_1)'/
     .       '                    *Datatype("Unknown")'/
     .       '                    *Request("Block 1")'/
     .       '                    *Component("',A,'")'/
     .       '                    *ScaleFactor("1")'/
     .       '                    *Offset("0")'/
     .       '                    *AxisIndex(',I1,')'/
     .       '                    *Attribute("HWReaderHints", "HWReaderHints", "String", "(USE_RXRESULT_READER_FOR_DSY)")'/
     .       '                    *Attribute("HWFile", "File", "String", PLOT_FILE_1)'/
     .       '                    *Attribute("HWSolver", "Solver", "String", "Unknown")'/
     .       '                    *Attribute("HWDatatype", "Datatype", "String", "Unknown")'/
     .       '                    *Attribute("HWRequest", "Request", "String", "Block 1")'/
     .       '                    *Attribute("HWComponent", "Component", "String", "',A,'")'/
     .       '                    *Attribute("HWComplexComponent", "ComplexComponent", "String", "',A,'")'/
     .       '                    *Attribute("HWReader", "Reader", "String", "hgtextcolumn.exe")'/
     .       '                    *Attribute("HWWordSize", "WordSize", "String", "8")'/
     .       '                *EndVector()'/
     .       '                *BeginVector(X, File)'/
     .       '                    *Filename(PLOT_FILE_1)'/
     .       '                    *Datatype("Unknown")'/
     .       '                    *Request("Block 1")'/
     .       '                    *Component("Cumulative iterations")'/
     .       '                    *ScaleFactor("1")'/
     .       '                    *Offset("0")'/
     .       '                    *AxisIndex(1)'/
     .       '                    *Attribute("HWReaderHints", "HWReaderHints", "String", "(USE_RXRESULT_READER_FOR_DSY)")'/
     .       '                    *Attribute("HWFile", "File", "String", PLOT_FILE_1)'/
     .       '                    *Attribute("HWSolver", "Solver", "String", "Unknown")'/
     .       '                    *Attribute("HWDatatype", "Datatype", "String", "Unknown")'/
     .       '                    *Attribute("HWRequest", "Request", "String", "Block 1")'/
     .       '                    *Attribute("HWComponent", "Component", "String", "Cumulative iterations")'/
     .       '                    *Attribute("HWComplexComponent", "ComplexComponent", "String", "Cumulative iterations")'/
     .       '                    *Attribute("HWReader", "Reader", "String", "hgtextcolumn.exe")'/
     .       '                    *Attribute("HWWordSize", "WordSize", "String", "8")'/
     .       '                *EndVector()'/
     .       '                *BeginVector(Time, File)'/
     .       '                    *Filename(PLOT_FILE_1)'/
     .       '                    *Datatype("Time")'/
     .       '                    *ScaleFactor("1")'/
     .       '                    *Offset("0")'/
     .       '                    *Attribute("HWReaderHints", "HWReaderHints", "String", "(USE_RXRESULT_READER_FOR_DSY)")'/
     .       '                    *Attribute("HWFile", "File", "String", PLOT_FILE_1)'/
     .       '                    *Attribute("HWSolver", "Solver", "String", "Unknown")'/
     .       '                    *Attribute("HWDatatype", "Datatype", "String", "Time")'/
     .       '                    *Attribute("HWRequest", "Request", "String", "Time")'/
     .       '                    *Attribute("HWComponent", "Component", "String", "Time")'/
     .       '                    *Attribute("HWComplexComponent", "ComplexComponent", "String", "Time")'/
     .       '                    *Attribute("HWReader", "Reader", "String", "hgtextcolumn.exe")'/
     .       '                    *Attribute("HWWordSize", "WordSize", "String", "8")'/
     .       '                *EndVector()'/
     .       '                *BeginVector(U, File)'/
     .       '                    *Filename(PLOT_FILE_1)'/
     .       '                    *Datatype("Unknown")'/
     .       '                    *Request("Block 1")'/
     .       '                    *Component("Cumulative iterations")'/
     .       '                    *ScaleFactor("1")'/
     .       '                    *Offset("0")'/
     .       '                    *AxisIndex(1)'/
     .       '                    *Attribute("HWReaderHints", "HWReaderHints", "String", "(USE_RXRESULT_READER_FOR_DSY)")'/
     .       '                    *Attribute("HWFile", "File", "String", PLOT_FILE_1)'/
     .       '                    *Attribute("HWSolver", "Solver", "String", "Unknown")'/
     .       '                    *Attribute("HWDatatype", "Datatype", "String", "Unknown")'/
     .       '                    *Attribute("HWRequest", "Request", "String", "Block 1")'/
     .       '                    *Attribute("HWComponent", "Component", "String", "Cumulative iterations")'/
     .       '                    *Attribute("HWComplexComponent", "ComplexComponent", "String", "Cumulative iterations")'/
     .       '                    *Attribute("HWReader", "Reader", "String", "hgtextcolumn.exe")'/
     .       '                    *Attribute("HWWordSize", "WordSize", "String", "8")'/
     .       '                *EndVector()'/
     .       '                *BeginVector(V, File)'/
     .       '                    *Filename(PLOT_FILE_1)'/
     .       '                    *Datatype("Unknown")'/
     .       '                    *Request("Block 1")'/
     .       '                    *Component("',A,'")'/
     .       '                    *ScaleFactor("1")'/
     .       '                    *Offset("0")'/
     .       '                    *AxisIndex(1)'/
     .       '                    *Attribute("HWReaderHints", "HWReaderHints", "String", "(USE_RXRESULT_READER_FOR_DSY)")'/
     .       '                    *Attribute("HWFile", "File", "String", PLOT_FILE_1)'/
     .       '                    *Attribute("HWSolver", "Solver", "String", "Unknown")'/
     .       '                    *Attribute("HWDatatype", "Datatype", "String", "Unknown")'/
     .       '                    *Attribute("HWRequest", "Request", "String", "Block 1")'/
     .       '                    *Attribute("HWComponent", "Component", "String", "',A,'")'/
     .       '                    *Attribute("HWComplexComponent", "ComplexComponent", "String", "',A,'")'/
     .       '                    *Attribute("HWReader", "Reader", "String", "hgtextcolumn.exe")'/
     .       '                    *Attribute("HWWordSize", "WordSize", "String", "8")'/
     .       '                *EndVector()'/
     .       '                *Attribute("HWLastGoodCurveName", "HWLastGoodCurveName", "String", "',A,'")'/
     .       '            *EndCurve()'
     .       )     
1003  FORMAT('        *EndPlot()')   
1004  FORMAT('        *ExportFormat("PNG")'/
     .       '        *BeginPlot()'/
     .       '            *PlotType(0)'/
     .       '            *BeginPlotHeader(On)'/
     .       '                *PrimaryFont("Arial", 0, 0, 14)'/
     .       '                *SecondaryFont("Arial", 0, 0, 10)'/
     .       '                *TertiaryFont("Arial", 0, 0, 10)'/
     .       '                *Color(0)'/
     .       '                *Text("{p1w',I1,'c1.y.HWComponent}")'/
     .       '                *HeaderAlignment(2)'/
     .       '            *EndPlotHeader()'/
     .       '            *BeginPlotFooter(Off)'/
     .       '                *PrimaryFont("Arial", 0, 0, 10)'/
     .       '                *SecondaryFont("Arial", 0, 0, 10)'/
     .       '                *TertiaryFont("Arial", 0, 0, 10)'/
     .       '                *Color(0)'/
     .       '                *Text("{p1w',I1,'c1.y.HWRequest} - {p1w',I1,'c1.y.HWComponent}")'/
     .       '                *FooterAlignment(2)'/
     .       '            *EndPlotFooter()'/
     .       '            *BeginLegend(On)'/
     .       '                *Font("Arial", 0, 0, 8)'/
     .       '                *BorderWidth(1)'/
     .       '                *Color(0)'/
     .       '                *Leader(Left)'/
     .       '                *Location(BELOW)'/
     .       '                *AutoPosition(False)'/
     .       '                *Reversed(no)'/
     .       '            *EndLegend()'/
     .       '            *UniformAspectRatio(0)'/
     .       '            *FrameColor(66)'/
     .       '            *BackgroundColor(1)'/
     .       '            *GridLineColor(9)'/
     .       '            *ZeroLineColor(0)'/
     .       '            *BeginAxis(X, "Primary", on)'/
     .       '                *Label("',A,'")'/
     .       '                *Scale(Linear)'/
     .       '                *TicMethod(Increment)'/
     .       '                *Min(0)'/
     .       '                *Max(1)'/
     .       '                *Format(Auto)'/
     .       '                *Precision(5)'/
     .       '                *Increment(10)'/
     .       '                *Grids(1)'/
     .       '                *Color(67)'/
     .       '                *AutoFit(TRUE)'/
     .       '                *LabelFont("Arial", 0, 0, 10)'/
     .       '                *TicsFont("Arial", 0, 0, 8)'/
     .       '                *FitRange(FALSE)'/
     .       '            *EndAxis()'/
     .       '            *BeginAxis(Y, "Primary", on)'/
     .       '                *Label("',A,'")'/
     .       '                *Scale(Linear)'/
     .       '                *TicMethod(PerAxis)'/
     .       '                *Min(0)'/
     .       '                *Max(1)'/
     .       '                *Format(Auto)'/
     .       '                *Precision(5)'/
     .       '                *Tics(11)'/
     .       '                *Grids(1)'/
     .       '                *Color(67)'/
     .       '                *AutoFit(TRUE)'/
     .       '                *LabelFont("Arial", 0, 0, 10)'/
     .       '                *TicsFont("Arial", 0, 0, 8)'/
     .       '                *FitRange(FALSE)'/
     .       '            *EndAxis()'
     .       )  
1005  FORMAT('        *EndPlot()'/
     .       '        *TimeScales(1, 1, 1)'/
     .       '        *TimeDelays(0, 0, 0)'/
     .       '        *AnimationEnable(1, 1, 1)'/
     .       '        *SyncTolerance(2e-008)'/
     .       '        *SyncTableGenerationPolicy(ALL_BLOCKS)'/
     .       '    *EndPage()'/
     .       '*EndDefine()'     
     .       )
1006  FORMAT('            *BeginCurve(',A,', "{y.HWComponent}")'/
     .       '                *Line(',I2,',',I2,',',I2,')'/
     .       '                *Symbol(',I2,',',I2,',',I2,')'/
     .       '                *Shade(False)'/
     .       '                *Bar(0, 0, 2)'/
     .       '                *ShowInLegend(True)'/
     .       '                *LayerNumber(31)'/
     .       '                *BeginVector(Y, File)'/
     .       '                    *Filename(PLOT_FILE_1)'/
     .       '                    *Datatype("Unknown")'/
     .       '                    *Request("Block 1")'/
     .       '                    *Component("',A,'")'/
     .       '                    *ScaleFactor("1")'/
     .       '                    *Offset("0")'/
     .       '                    *AxisIndex(',I1,')'/
     .       '                    *Attribute("HWReaderHints", "HWReaderHints", "String", "(USE_RXRESULT_READER_FOR_DSY)")'/
     .       '                    *Attribute("HWFile", "File", "String", PLOT_FILE_1)'/
     .       '                    *Attribute("HWSolver", "Solver", "String", "Unknown")'/
     .       '                    *Attribute("HWDatatype", "Datatype", "String", "Unknown")'/
     .       '                    *Attribute("HWRequest", "Request", "String", "Block 1")'/
     .       '                    *Attribute("HWComponent", "Component", "String", "',A,'")'/
     .       '                    *Attribute("HWComplexComponent", "ComplexComponent", "String", "',A,'")'/
     .       '                    *Attribute("HWReader", "Reader", "String", "hgtextcolumn.exe")'/
     .       '                    *Attribute("HWWordSize", "WordSize", "String", "8")'/
     .       '                *EndVector()'/
     .       '                *BeginVector(X, File)'/
     .       '                    *Filename(PLOT_FILE_1)'/
     .       '                    *Datatype("Unknown")'/
     .       '                    *Request("Block 1")'/
     .       '                    *Component("Arc length")'/
     .       '                    *ScaleFactor("1")'/
     .       '                    *Offset("0")'/
     .       '                    *AxisIndex(1)'/
     .       '                    *Attribute("HWReaderHints", "HWReaderHints", "String", "(USE_RXRESULT_READER_FOR_DSY)")'/
     .       '                    *Attribute("HWFile", "File", "String", PLOT_FILE_1)'/
     .       '                    *Attribute("HWSolver", "Solver", "String", "Unknown")'/
     .       '                    *Attribute("HWDatatype", "Datatype", "String", "Unknown")'/
     .       '                    *Attribute("HWRequest", "Request", "String", "Block 1")'/
     .       '                    *Attribute("HWComponent", "Component", "String", "Arc length")'/
     .       '                    *Attribute("HWComplexComponent", "ComplexComponent", "String", "Arc length")'/
     .       '                    *Attribute("HWReader", "Reader", "String", "hgtextcolumn.exe")'/
     .       '                    *Attribute("HWWordSize", "WordSize", "String", "8")'/
     .       '                *EndVector()'/
     .       '                *BeginVector(Time, File)'/
     .       '                    *Filename(PLOT_FILE_1)'/
     .       '                    *Datatype("Time")'/
     .       '                    *ScaleFactor("1")'/
     .       '                    *Offset("0")'/
     .       '                    *Attribute("HWReaderHints", "HWReaderHints", "String", "(USE_RXRESULT_READER_FOR_DSY)")'/
     .       '                    *Attribute("HWFile", "File", "String", PLOT_FILE_1)'/
     .       '                    *Attribute("HWSolver", "Solver", "String", "Unknown")'/
     .       '                    *Attribute("HWDatatype", "Datatype", "String", "Time")'/
     .       '                    *Attribute("HWRequest", "Request", "String", "Time")'/
     .       '                    *Attribute("HWComponent", "Component", "String", "Time")'/
     .       '                    *Attribute("HWComplexComponent", "ComplexComponent", "String", "Time")'/
     .       '                    *Attribute("HWReader", "Reader", "String", "hgtextcolumn.exe")'/
     .       '                    *Attribute("HWWordSize", "WordSize", "String", "8")'/
     .       '                *EndVector()'/
     .       '                *BeginVector(U, File)'/
     .       '                    *Filename(PLOT_FILE_1)'/
     .       '                    *Datatype("Unknown")'/
     .       '                    *Request("Block 1")'/
     .       '                    *Component("Arc length")'/
     .       '                    *ScaleFactor("1")'/
     .       '                    *Offset("0")'/
     .       '                    *AxisIndex(1)'/
     .       '                    *Attribute("HWReaderHints", "HWReaderHints", "String", "(USE_RXRESULT_READER_FOR_DSY)")'/
     .       '                    *Attribute("HWFile", "File", "String", PLOT_FILE_1)'/
     .       '                    *Attribute("HWSolver", "Solver", "String", "Unknown")'/
     .       '                    *Attribute("HWDatatype", "Datatype", "String", "Unknown")'/
     .       '                    *Attribute("HWRequest", "Request", "String", "Block 1")'/
     .       '                    *Attribute("HWComponent", "Component", "String", "Arc length")'/
     .       '                    *Attribute("HWComplexComponent", "ComplexComponent", "String", "Arc length")'/
     .       '                    *Attribute("HWReader", "Reader", "String", "hgtextcolumn.exe")'/
     .       '                    *Attribute("HWWordSize", "WordSize", "String", "8")'/
     .       '                *EndVector()'/
     .       '                *BeginVector(V, File)'/
     .       '                    *Filename(PLOT_FILE_1)'/
     .       '                    *Datatype("Unknown")'/
     .       '                    *Request("Block 1")'/
     .       '                    *Component("',A,'")'/
     .       '                    *ScaleFactor("1")'/
     .       '                    *Offset("0")'/
     .       '                    *AxisIndex(1)'/
     .       '                    *Attribute("HWReaderHints", "HWReaderHints", "String", "(USE_RXRESULT_READER_FOR_DSY)")'/
     .       '                    *Attribute("HWFile", "File", "String", PLOT_FILE_1)'/
     .       '                    *Attribute("HWSolver", "Solver", "String", "Unknown")'/
     .       '                    *Attribute("HWDatatype", "Datatype", "String", "Unknown")'/
     .       '                    *Attribute("HWRequest", "Request", "String", "Block 1")'/
     .       '                    *Attribute("HWComponent", "Component", "String", "',A,'")'/
     .       '                    *Attribute("HWComplexComponent", "ComplexComponent", "String", "',A,'")'/
     .       '                    *Attribute("HWReader", "Reader", "String", "hgtextcolumn.exe")'/
     .       '                    *Attribute("HWWordSize", "WordSize", "String", "8")'/
     .       '                *EndVector()'/
     .       '                *Attribute("HWLastGoodCurveName", "HWLastGoodCurveName", "String", "',A,'")'/
     .       '            *EndCurve()'
     .       )     
C------------------------------------------
      RETURN
      END      
c
Chd|====================================================================
Chd|  INT5_DIVERG                   source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|====================================================================
      SUBROUTINE INT5_DIVERG(IPARI )
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER  IPARI(NPARI,*)
C     REAL
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER  N, NTY
C--------------------------------------------
      DO N=1,NINTER
        NTY   =IPARI(7,N)
C-----------------------------------------------------------------------
        IF(NTY == 5 ) THEN
C-----------------------------------------------------------------------
          IPARI(16,N)=IPARI(16,N)-1
C-----------------------------------------------------------------------
        ELSEIF(NTY == 10)THEN
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
        ELSEIF(NTY == 11)THEN
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
        ELSEIF(NTY == 24 ) THEN
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
         ENDIF
      END DO
C-----------------------------------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  DIS_CP                        source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        CP_REAL                       source/implicit/produt_v.F    
Chd|        IMP_QSTAT                     share/modules/impbufdef_mod.F 
Chd|====================================================================
      SUBROUTINE DIS_CP(N     ,D      ,DR   ,IFLAG   )
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE IMP_QSTAT
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER  N,IFLAG
C     REAL
      my_real
     . D(*),DR(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,ND
C------------------------------------------
      IF (IFLAG ==0 ) THEN
        CALL CP_REAL(N,D, D_N_1)
        IF (IRODDL/=0) CALL CP_REAL(N,DR, DR_N_1)
      ELSE
        CALL CP_REAL(N,D_N_1 ,D )
        IF (IRODDL/=0) CALL CP_REAL(N,DR_N_1,DR )
      END IF
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  IMP_SMPINI                    source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        B_CORRECT_HP                  source/implicit/nl_solv.F     
Chd|        CP_INT_HP                     source/implicit/produt_v.F    
Chd|        CP_REAL_HP                    source/implicit/produt_v.F    
Chd|        DU_INI_HP                     source/implicit/imp_solv.F    
Chd|        FRAC_DD_HP                    source/implicit/integrator.F  
Chd|        FRAC_D_HP                     source/implicit/integrator.F  
Chd|        INTEGRATOR1_HP                source/implicit/integrator.F  
Chd|        INTEGRATOR2_HP                source/implicit/integrator.F  
Chd|        INTEGRATORL_HP                source/implicit/integrator.F  
Chd|        INTEGRATOR_HP                 source/implicit/integrator.F  
Chd|        LIN_SOLV                      source/implicit/lin_solv.F    
Chd|        MUMPSLB_HP                    source/implicit/lin_solv.F    
Chd|        PRODUT_HP                     source/implicit/produt_v.F    
Chd|        PRODUT_UHP0                   source/implicit/produt_v.F    
Chd|        VAXPY_HP                      source/implicit/produt_v.F    
Chd|        VSCALY_HP                     source/implicit/produt_v.F    
Chd|        VSCAL_HP                      source/implicit/produt_v.F    
Chd|        ZEROR_HP                      source/implicit/produt_v.F    
Chd|-- calls ---------------
Chd|====================================================================
      SUBROUTINE IMP_SMPINI(
     1   ITSK   ,N1FTSK ,N1LTSK ,N1   )
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "task_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER ITSK   ,N1FTSK ,N1LTSK ,N1   
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
      INTEGER OMP_GET_THREAD_NUM
      EXTERNAL OMP_GET_THREAD_NUM 
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
C      
C     Initialisation des variables pour // SMP
C 
      ITSK = OMP_GET_THREAD_NUM()
      N1FTSK = 1+ITSK*N1/ NTHREAD
      N1LTSK = (ITSK+1)*N1/ NTHREAD
C
      RETURN
      END
Chd|====================================================================
Chd|  DU_INI_HP                     source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        IMP_SMPINI                    source/implicit/imp_solv.F    
Chd|        IMP_DYNA                      share/modules/impbufdef_mod.F 
Chd|====================================================================
      SUBROUTINE DU_INI_HP(DN     ,DNR    ,DD    ,
     1                     DDR   ,IDIV   ,ICONT0 )
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE IMP_DYNA
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "impl1_c.inc"
#include      "impl2_c.inc"
#include      "com01_c.inc"
#include      "com04_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER IDIV   ,ICONT0
      my_real
     . DN(3,*),DNR(3,*),DD(3,*),DDR(3,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER NODFT ,NODLT,ITSK
      INTEGER I,J,IRES
      my_real
     .  BFAC,BDT
C--------------Dn,0=Dn-1--------
C--------special case with /QSTAT diverge by contact, restart w/o resolution
        IRES = 1
        IF (IQSTAT >0 .AND. IDIV==-2 .AND. ICONT0 >0 ) THEN
         IDIV=-1
         IRES=0
        END IF
C        
        BFAC=DT1_IMP/DT0_IMP
!$OMP PARALLEL PRIVATE(ITSK,NODFT ,NODLT,I,BDT)
       CALL IMP_SMPINI(ITSK   ,NODFT ,NODLT,NUMNOD  )
        IF (IDYNA==0) THEN
         IF (ISMDISP>0.OR.IRES==0) THEN
          DO I = NODFT ,NODLT
               DD(1,I) = BFAC*DN(1,I)
               DD(2,I) = BFAC*DN(2,I)
               DD(3,I) = BFAC*DN(3,I)
              END DO
          IF (IRODDL/=0) THEN
           DO I = NODFT ,NODLT
                DDR(1,I) = BFAC*DNR(1,I)
                DDR(2,I) = BFAC*DNR(2,I)
                DDR(3,I) = BFAC*DNR(3,I)
               END DO
          END IF
             ELSE
          DO I = NODFT ,NODLT
               DD(1,I) = DN(1,I)
               DD(2,I) = DN(2,I)
               DD(3,I) = DN(3,I)
              ENDDO
         IF (IRODDL/=0) THEN
          DO I = NODFT ,NODLT
               DDR(1,I) = DNR(1,I)
               DDR(2,I) = DNR(2,I)
               DDR(3,I) = DNR(3,I)
              ENDDO
          END IF
         END IF
            ELSE
         BDT = HALF*DT0_IMP*DT0_IMP*(ONE-TWO*DY_B)
             BDT = ZERO
         DO I = NODFT ,NODLT
              DD(1,I) = BFAC*DN(1,I)+BDT*DY_A(1,I)
              DD(2,I) = BFAC*DN(2,I)+BDT*DY_A(2,I)
              DD(3,I) = BFAC*DN(3,I)+BDT*DY_A(3,I)
             END DO
         IF (IRODDL/=0) THEN
          DO I = NODFT ,NODLT
               DDR(1,I) = BFAC*DNR(1,I)+BDT*DY_AR(1,I)
               DDR(2,I) = BFAC*DNR(2,I)+BDT*DY_AR(2,I)
               DDR(3,I) = BFAC*DNR(3,I)+BDT*DY_AR(3,I)
              END DO
         END IF
            END IF
!$OMP END PARALLEL
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  PRINT_STIF                    source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|-- calls ---------------
Chd|        INTBUFDEF_MOD                 ../common_source/modules/intbufdef_mod.F
Chd|        TRI7BOX                       share/modules/tri7box.F       
Chd|====================================================================
      SUBROUTINE PRINT_STIF(IPARI,INTBUF_TAB,IFLAG,NN     ,JG    )
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE TRI7BOX   
      USE INTBUFDEF_MOD
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "units_c.inc"
#include      "param_c.inc"
#include      "task_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER IPARI(NPARI,NINTER)
      INTEGER IFLAG, NN     ,JG
      INTEGER LENS, LENR,P,N
      INTEGER IEDGE,NSN

      TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
C------------------------------------------
       return
      IF (NSPMD==1) THEN
      NSN   =IPARI(5,NN)
      N = 21
      if (NCYCLE>=81.and.NCYCLE<=81) then
c         write(iout,*)'IFLAG,ISPMD=',IFLAG,ISPMD
c         write(iout,*)'IRTLM(1,)=',INBUF(K1)
c      call my_flush(6)
      end if
      ELSE
              LENS = 0
              LENR = 0
              DO P = 1, NSPMD
                LENS = LENS + NSNSI(NN)%P(P)
                LENR = LENR + NSNFI(NN)%P(P)
              END DO
      if (NCYCLE>=80.and.NCYCLE<=81.AND.LENR >0) then
         write(iout,*)'IFLAG,ISPMD=',IFLAG,ISPMD
         write(iout,*)'STIF_OLDFI()%P(1=',STIF_OLDFI(NN)%P(1,JG)
      end if
c      if (NCYCLE>=78.and.NCYCLE<=79.AND.LENS >0) then
c       N = 55
c       K1 = KD(16)+ 2*(N -1)
c         write(iout,*)'IFLAG,ISPMD=',IFLAG,ISPMD
c         write(iout,*)'IRTLM(1,N)=',INBUF(K1)
c      end if
      END IF !(NSPMD==1) THEN
      RETURN
      END
Chd|====================================================================
Chd|  IMP_STIF24                    source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        RE2INT7                       source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        SPMD_ALLGLOB_ISUM9            source/mpi/generic/spmd_allglob_isum9.F
Chd|        IMP_I7CP                      share/modules/imp_intm.F      
Chd|        TRI7BOX                       share/modules/tri7box.F       
Chd|====================================================================
      SUBROUTINE IMP_STIF24(NUMIMP  ,IPARI   )
C-----------------------------------------------
      USE TRI7BOX
      USE IMP_I7CP
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "com08_c.inc"
#include      "impl1_c.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER  NUMIMP(*),IPARI(NPARI,*)
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,K,L,N,IAD,N_MAX(NINTER),IFLAG,P,
     .       ITY,NSN,IGSTI,IBIT,RID,INTTH,
     .       IGAP,INACTI,IN1CON,NCONT0,NREBOU
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
C-----Calcul NCONT0, Communication is necessary
       IF (TT == ZERO.AND.INCONV==1) THEN
        DO N = 1,NINTER
         ITY   =IPARI(7,N)
         IF (ITY==24) THEN
          IPARI(26,N)= 0
          IPARI(53,N)= 0
         END IF
        END DO
       END IF
        IFLAG=0
        DO N = 1,NINTER
         ITY   =IPARI(7,N)
         IGSTI =IPARI(34,N)
             N_MAX(N)=0
         IF (ITY == 24.AND.IGSTI==6) THEN
          N_MAX(N) =NUMIMP(N)
          IFLAG=1
         END IF
        END DO
       IF (IFLAG==0.OR.IMCONV<0) RETURN
C       
       IF (NSPMD>1) CALL SPMD_ALLGLOB_ISUM9(N_MAX,NINTER)

       DO N = 1,NINTER
         ITY   =IPARI(7,N)
         IGSTI =IPARI(34,N)
        IF (ITY /= 24.AND.IGSTI/=6) CYCLE
        IN1CON =IPARI(26,N)
        NCONT0 =IPARI(27,N)
        NREBOU =IPARI(53,N)
        IF (N_MAX(N)>0 .AND. IN1CON==0) THEN
         IF (INCONV==1) THEN
          IN1CON = NCYCLE+1
         ELSE 
          IN1CON = NCYCLE
         END IF
        END IF
C---------rebound----        
        IF (NCONT0>0 .AND.N_MAX(N)==0) THEN
C------first one will keep negative IN1CON till converging         
         IF (NCYCLE == IN1CON) THEN
          NREBOU=1
         ELSE
C--------rebound nb >2       
          NREBOU=2
         END IF
c        write(iout,*)'NREBOU,NIN,imconv,ispmd=',
c     +                NREBOU,N,imconv,ispmd
C---------negative :rebound active          
         IPARI(53,N)=-NREBOU
        END IF 
        IPARI(26,N)=IN1CON
        IPARI(27,N)=N_MAX(N)
       END DO
C
      RETURN
      END
Chd|====================================================================
Chd|  UPD_RHS_FR                    source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_INTFR                     source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        EXT_RHS                       source/implicit/upd_glob_k.F  
Chd|        I2_IMPR1                      source/interfaces/interf/i2_imp1.F
Chd|        I2_IMPR2                      source/interfaces/interf/i2_imp1.F
Chd|        RBE2_IMPR1                    source/constraints/general/rbe2/rbe2_imp0.F
Chd|        RBE3_IMPR1                    source/constraints/general/rbe3/rbe3_imp0.F
Chd|        RBE3_IMPR2                    source/constraints/general/rbe3/rbe3_imp0.F
Chd|        RBY_IMPR1                     source/constraints/general/rbody/rby_imp0.F
Chd|        RBY_IMPR2                     source/constraints/general/rbody/rby_imp0.F
Chd|        INTBUFDEF_MOD                 ../common_source/modules/intbufdef_mod.F
Chd|====================================================================
      SUBROUTINE UPD_RHS_FR(ICODT ,ICODR ,ISKEW ,IBFV    ,XFRAME ,
     1                   RBY   ,X     ,SKEW   ,LPBY   ,NPBY   ,
     2                   NRBYAC,IRBYAC,NINT2  ,IINT2  ,IPARI  ,
     3                   INTBUF_TAB   ,NDOF   ,IDDL   ,IKC    ,
     4                   NDDL0 ,B     ,IUPD   ,INLOC  ,LJ     ,
     5                   AC    ,ACR   ,NT_RW  ,W_DDL  ,NDDL   ,
     6                   R02   ,IRBE3 ,LRBE3  ,FRBE3  ,WEIGHT ,
     8                   IRBE2 ,LRBE2 )
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE INTBUFDEF_MOD
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER IBFV(NIFV,*),ICODT(*),ICODR(*),ISKEW(*),
     .        NINT2 ,IINT2(*),LJ(*),NDDL0,IUPD,
     .        INLOC(*),NT_RW,W_DDL(*) ,NDDL
      INTEGER LPBY(*),NPBY(NNPBY,*),NDOF(*),IDDL(*),IKC(*),
     .        IPARI(NPARI,*), NRBYAC,IRBYAC(*)
      INTEGER WEIGHT(*),IRBE3(*),LRBE3(*),IRBE2(*),LRBE2(*)
      my_real
     .   RBY(NRBY,*) ,X(3,*) ,SKEW(*),R02
      my_real
     .  B(*) ,XFRAME(NXFRAME,*),AC(3,*),ACR(3,*),FRBE3(*)

      TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,K,N,JI,JB,K1,IFLAG
C-------R02 correction due the fact that IMP_FRI is done after [K],{LB}condensation----------
C-------only Fext is re-computed, others don't change-------
C-------int2,RBE3,rby speciale (Fext seulement)----------
        IF (IUPD==0) THEN
         DO I=1,NINT2
          N=IINT2(I)
          CALL I2_IMPR1(IPARI(1,N),INTBUF_TAB(N),
     .                  X  ,NDOF ,IDDL    ,B  )
         ENDDO
         IF (NRBE2>0) THEN
          CALL RBE2_IMPR1(
     1                    IRBE2  ,LRBE2 ,X     ,SKEW   ,NDOF   ,
     2                    IDDL   ,B     ,WEIGHT)
         ENDIF
         IF (NRBE3>0) THEN
          CALL RBE3_IMPR1(
     1                    IRBE3  ,LRBE3 ,FRBE3  ,X     ,SKEW   ,
     2                    NDOF   ,IDDL  ,B      ,WEIGHT)
         ENDIF
         DO I=1,NRBYAC
          N=IRBYAC(I)
          K1=IRBYAC(I+NRBYKIN)+1
          CALL RBY_IMPR1(X, RBY(1,N),LPBY(K1),NPBY(1,N),
     1                   NDOF  ,IDDL   ,B    )
         ENDDO
        ENDIF
C-------int2,rby speciale (elems deleted)----------
         DO I=1,NINT2
          N=IINT2(I)
          CALL I2_IMPR2(IPARI(1,N),INTBUF_TAB(N) ,AC    ,ACR  ,
     .                  X  ,NDOF ,IDDL    ,B  )
         ENDDO
         IF (NRBE3>0) THEN
          CALL RBE3_IMPR2(
     1                    IRBE3  ,LRBE3 ,FRBE3  ,X     ,SKEW   ,
     2                    NDOF   ,IDDL  ,B      ,WEIGHT,AC     ,
     3                    ACR    )
         ENDIF
         DO I=1,NRBYAC
          N=IRBYAC(I)
          K1=IRBYAC(I+NRBYKIN)+1
          CALL RBY_IMPR2(X, RBY(1,N),LPBY(K1),NPBY(1,N),
     1                   NDOF  ,IDDL   ,B    ,AC    ,ACR  )
         ENDDO
C-------------
         CALL EXT_RHS(ICODT ,ICODR ,ISKEW ,IBFV    ,XFRAME ,
     1                X     ,SKEW  ,NDOF  ,IDDL    ,IKC    ,
     2                NDDL0 ,B     ,INLOC  ,LJ     ,AC     ,
     3                ACR   ,NT_RW ,W_DDL  ,NDDL   ,R02    )
C
      RETURN
      END
Chd|====================================================================
Chd|  IMP_INTFR                     source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        CP_REAL_HP                    source/implicit/produt_v.F    
Chd|        IMP_FRFV                      source/mpi/implicit/imp_fri.F 
Chd|        IMP_FRI                       source/mpi/implicit/imp_fri.F 
Chd|        IMP_SETBA                     source/implicit/imp_setb.F    
Chd|        UPD_RHS_FR                    source/implicit/imp_solv.F    
Chd|        INTBUFDEF_MOD                 ../common_source/modules/intbufdef_mod.F
Chd|====================================================================
      SUBROUTINE IMP_INTFR(
     1    NUM_IMP   ,NS_IMP    ,NE_IMP    ,IPARI     ,INTBUF_TAB,
     2    NPBY      ,LPBY      ,ITAB      ,NRBYAC    ,
     3    IRBYAC    ,NINT2     ,IINT2     ,IDDL      ,IKC       ,
     4    NDOF      ,INLOC     ,NSREM     ,NSL       ,NBINTC    ,
     5    INTLIST   ,X         ,IBFV      ,DIRUL     ,SKEW      ,
     6    XFRAME    ,ISKEW     ,ICODT     ,DE        ,D_IMP     ,
     7    LB        ,IFDIS     ,NDDL      ,DR_IMP    ,IDDLI     ,
     8    IRBE3     ,LRBE3     ,FRBE3     ,IRBE2     ,LRBE2     ,
     9    DD        ,DDR       ,A         ,AR        ,AC        ,
     A    ACR       ,MS        ,V         ,NDDL0     ,R02       ,
     B    RBY       ,ICODR     ,NT_RW     ,W_DDL     ,WEIGHT    ,
     C    IRFLAG    )
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE INTBUFDEF_MOD
C----6---------------------------------------------------------------7---------8
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "param_c.inc"
#include      "impl1_c.inc"
C-----------------------------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER IPARI(NPARI,*),NUM_IMP(*),NS_IMP(*),
     .        NE_IMP(*),NSREM  ,NSL,NBINTC,INTLIST(*),IRFLAG,
     .        IRBE3(*),LRBE3(*),IRBE2(*),LRBE2(*),NDDL0,W_DDL(*),
     .        WEIGHT(*),ICODR(*),NT_RW
      INTEGER NPBY(NNPBY,*),LPBY(*),ITAB(*),NRBYAC,IRBYAC(*),
     .        NINT2,IINT2(*),IDDL(*),IKC(*),NDOF(*),INLOC(*),
     .        IBFV(*),DIRUL(*),ISKEW(*),ICODT(*),IFDIS,NDDL,IDDLI(*)
C     REAL
      my_real
     .       X(3,*),SKEW(*) ,XFRAME(*),
     .       A(3,*),D_IMP(3,*),LB(*),DR_IMP(3,*),FRBE3(*),
     .       DD(3,*),DDR(3,*),AR(3,*),MS(*) ,V(3,*),DE,
     .       AC(3,*),ACR(3,*),R02,RBY(NRBY,*)

      TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,N,NKC,ND,NDM
      INTEGER, DIMENSION(NDDL0) :: IDM
      my_real, DIMENSION(NDDL0) :: LB0
C       
          CALL CP_REAL_HP(NDDL,LB,LB0)
            CALL IMP_FRI(
     1    NUM_IMP   ,NS_IMP    ,NE_IMP    ,IPARI     ,INTBUF_TAB,
     2    NPBY      ,LPBY      ,ITAB      ,NRBYAC    ,
     3    IRBYAC    ,NINT2     ,IINT2     ,IDDL      ,IKC       ,
     4    NDOF      ,INLOC     ,NSREM     ,NSL       ,NBINTC    ,
     5    INTLIST   ,X         ,IBFV      ,DIRUL     ,SKEW      ,
     6    XFRAME    ,ISKEW     ,ICODT     ,A         ,D_IMP     ,
     7    LB        ,IFDIS     ,NDDL      ,DR_IMP    ,IDDLI     ,
     8    IRBE3     ,LRBE3     ,FRBE3     ,IRBE2     ,LRBE2     )
            IF ( IFDIS>0 .AND. INTP_C <= 0)
     .       CALL IMP_FRFV(
     1    NUM_IMP   ,NS_IMP    ,NE_IMP    ,IPARI     ,INTBUF_TAB,
     2    IDDL      ,IKC       ,NDOF      ,NSREM     ,
     3    NSL       ,D_IMP     ,DD        ,DR_IMP    ,DDR       ,
     4    A         ,AR        ,MS        ,V         ,X         ,
     5    LB        ,NDDL      ,IBFV      ,SKEW      ,XFRAME    ,
     6    IRBE3     ,LRBE3     ,IRBE2     ,LRBE2     ,DE        ,
     7    NDDL0     ,W_DDL     )
C--------Fext change (U_d) w/ remot  to re-evalue R02   
        IF (IRFLAG>0) THEN
         DO I =1,NDDL
          LB0(I) =LB(I)-LB0(I)
         END DO
         DO I =NDDL+1,NDDL0
          LB0(I) =ZERO
         END DO
         NKC=0
C------LB0 condensed -> LB0 original         
         DO N =1,NUMNOD
          I=INLOC(N)
          NDM=IDDL(I)-NKC
          DO J=1,NDOF(I)
           ND = IDDL(I)+J
           IF (IKC(ND)/=0) THEN
            NKC = NKC + 1
            IDM(ND)=0
           ELSE
            NDM=NDM+1
            IDM(ND)=NDM
           END IF
          ENDDO
         ENDDO
         DO I =NDDL0,1,-1
          ND = IDM(I)
          IF (ND>0) LB0(I) =LB0(ND)
         END DO
         CALL IMP_SETBA(AC    ,ACR     ,IDDL   ,NDOF  ,LB0   ,1 )
         CALL UPD_RHS_FR(ICODT ,ICODR ,ISKEW ,IBFV    ,XFRAME ,
     1                   RBY   ,X     ,SKEW   ,LPBY   ,NPBY   ,
     2                   NRBYAC,IRBYAC,NINT2  ,IINT2  ,IPARI  ,
     3                   INTBUF_TAB   ,NDOF   ,IDDL   ,IKC    ,
     4                   NDDL0 ,LB0   ,ISETK  ,INLOC  ,DIRUL  ,
     5                   AC    ,ACR   ,NT_RW  ,W_DDL  ,NDDL   ,
     6                   R02   ,IRBE3 ,LRBE3  ,FRBE3  ,WEIGHT ,
     8                   IRBE2 ,LRBE2 )
        ENDIF
C----6---------------------------------------------------------------7---------8
      RETURN
      END
Chd|====================================================================
Chd|  INI_BMINMA_IMP                source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        IMP_INTBUF                    share/modules/imp_mod_def.F   
Chd|====================================================================
      SUBROUTINE INI_BMINMA_IMP
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE IMP_INTBUF
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER  N
C-----------------------------------------------
        ALLOCATE(BMINMA_IMP(6,NINTER))
        DO N = 1,NINTER
         BMINMA_IMP(1,N)=-EP30
         BMINMA_IMP(2,N)=-EP30
         BMINMA_IMP(3,N)=-EP30
         BMINMA_IMP(4,N)=EP30
         BMINMA_IMP(5,N)=EP30
         BMINMA_IMP(6,N)=EP30
        END DO
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  SPBRM_PRE                     source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        CGSHELL3                      source/implicit/cgshell.F     
Chd|        CGSHELL4                      source/implicit/cgshell.F     
Chd|        SPB_REFSH3ID                  source/implicit/imp_solv.F    
Chd|        SPB_REFSH4ID                  source/implicit/imp_solv.F    
Chd|        SPMD_MAX_I                    source/mpi/implicit/imp_spmd.F
Chd|        SPMD_MIN_S                    source/mpi/implicit/imp_spmd.F
Chd|        SPMD_SUM_S                    source/mpi/implicit/imp_spmd.F
Chd|        ELBUFDEF_MOD                  ../common_source/modules/mat_elem/elbufdef_mod.F
Chd|        IMP_SPBRM                     share/modules/impbufdef_mod.F 
Chd|====================================================================
      SUBROUTINE SPBRM_PRE(ITAB ,
     1    X         ,IPARG     ,IXC       ,IXTG      ,PARTSAV   ,
     2    ELBUF_TAB ,PM        ,NDOF      ,IDDL      ,IKC       )
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE ELBUFDEF_MOD
      USE IMP_SPBRM
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "param_c.inc"
#include      "impl1_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER
     .   IXC(NIXC,*), IXTG(NIXTG,*), IPARG(NPARG,*),  
     .    NDOF(*),IDDL(*),IKC(*),ITAB(*)
C     REAL
      my_real
     .   X(3,*)  ,PARTSAV(NPSAV,*) ,PM(*)  
      TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP)      :: ELBUF_TAB
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER  N4,N3,I,II,J,N, NG,MLW, NF1,NKC,ND,IP4,IP3,IG,
     +         JFT,JLT,NBC,ITY,NEL,NFT,NBCS,E_ID,N1,N2,K
      INTEGER, DIMENSION(:),ALLOCATABLE :: ITAG
C     REAL
      my_real
     .     XC,YC,ZC,MAS,MAS3,DMIN,XMIN,YMIN,ZMIN,MAST,
     .     DMING,XMING,YMING,ZMING
C---limitations : only the blank is deformable(shell only), all tools(part)are rigids---
C------------blank could be composed w/ 4N,3N and in diff parts
C------ IRIG_M>1 -> input E_REF id
C---IF there id BC (symmetry) in the blank----
C----- put N1,N2,N3 (sys_id) in E_REF(1:3),  E_REF(4)=E_REF(3)      
       RLSKEW(1:9) = ZERO        
       IF (IRIG_M>1 ) THEN
        NBC_B = 0
        ILSKEW = 0
        LSKEW_G = 0
        IKCE(1:6) = 0
        N1=0
        N2=0
        N3=0
        DO I = 1, NUMNOD
         IF(ITAB(I)==E_REF(1)) N1=I
         IF(ITAB(I)==E_REF(2)) N2=I
         IF(ITAB(I)==E_REF(3)) N3=I
        END DO
        E_REF(1)= N1
        E_REF(2)= N2
        E_REF(3)= N3
        DO J = 1, 3
         N = E_REF(J)
         IF (N==0) CYCLE
         DO K= 1,NDOF(N)
          ND = IDDL(N)+K
          IF (IKC(ND)>0.AND.IKCE(K)==0) IKCE(K) = 1
          IF (IKC(ND)==8) ILSKEW = N
         END DO
        END DO 
        IF (ILSKEW >0)  LSKEW_G=1
C----  end routine      
        RETURN
       END IF
       NBC = 0
       DO I =1,NUMNOD
        NKC=0
        DO J=1,MIN(3,NDOF(I))
         ND = IDDL(I)+J
         IF (IKC(ND)/=0) NKC = NKC + 1
        ENDDO
C--------exclude fixing all translational       
        IF (NKC>0.AND.NKC<3) NBC = NBC +1
       ENDDO
       IF (NBC >0) THEN
C----------pense      deallocate       
        AllOCATE(IBC_B(NBC))
        NBC = 0
        DO I =1,NUMNOD
         NKC=0
         DO J=1,MIN(3,NDOF(I))
          ND = IDDL(I)+J
          IF (IKC(ND)/=0) NKC = NKC + 1
         ENDDO
         IF (NKC>0.AND.NKC<3) THEN
          NBC = NBC +1
          IBC_B(NBC) = I
         END IF
        ENDDO
       END IF
C------global NBC---       
      NBC_B = NBC
      IF (NSPMD>1) CALL SPMD_MAX_I(NBC_B)
C---get reference elem (shell for the moment) for rigid motion compute
C---- E_id : nearest the gravity center if no BC, 
C-----E_REF(4) saved 4 nodes which are Xmin, Ymin,Zmin,Dmin, will be updated by v,vr
      IF (NBC >0) THEN
       ALLOCATE(ITAG(NUMNOD))
       ITAG = 0
       DO I =1,NBC
         N = IBC_B(I)
         ITAG(N) =1
       END DO
       NE_BC4 = 0
       NE_BC3 = 0
       DO NG = 1, NGROUP
          IF(IPARG(8,NG)==1) CYCLE
          ITY   =IPARG(5,NG)
          IF (ITY /= 3 .AND. ITY /= 7) CYCLE
          MLW   =IPARG(1,NG)
C 
          IF (MLW == 0 .OR. MLW == 13) CYCLE
          NEL   =IPARG(2,NG)
          JFT   =IPARG(3,NG) + 1
          JLT   = IPARG(3,NG) + NEL
          IF (ITY==7) THEN
           DO I = JFT,JLT 
            NBCS = 0           
            DO J=1,3
             N= IXTG(J+1,I)
             NBCS = NBCS + ITAG(N)
            END DO
            IF (NBCS >0) NE_BC3 =NE_BC3 + 1
           END DO
          ELSEIF (ITY==3) THEN
           DO I = JFT,JLT 
            NBCS = 0           
            DO J=1,4
             N= IXC(J+1,I)
             NBCS = NBCS + ITAG(N)
            END DO
            IF (NBCS >0) NE_BC4 =NE_BC4 + 1
           END DO
          END IF
       END DO !NG = 1, NGROUP
       IF (NE_BC3 >0) ALLOCATE(IE_BC3(NE_BC3))
       IF (NE_BC4 >0) ALLOCATE(IE_BC4(NE_BC4))
       NE_BC4 = 0
       NE_BC3 = 0
       DO NG = 1, NGROUP
          IF(IPARG(8,NG)==1) CYCLE
          ITY   =IPARG(5,NG)
          IF (ITY /= 3 .AND. ITY /= 7) CYCLE
          MLW   =IPARG(1,NG)
C 
          IF (MLW == 0 .OR. MLW == 13) CYCLE
          NEL   =IPARG(2,NG)
          JFT   =IPARG(3,NG) + 1
          JLT   = IPARG(3,NG) + NEL
          IF (ITY==7) THEN
           DO I = JFT,JLT 
            NBCS = 0           
            DO J=1,3
             N= IXTG(J+1,I)
             NBCS = NBCS + ITAG(N)
            END DO
            IF (NBCS >0) THEN
             NE_BC3 =NE_BC3 + 1
             IE_BC3(NE_BC3) = I
            END IF
           END DO
          ELSEIF (ITY==3) THEN
           DO I = JFT,JLT 
            NBCS = 0           
            DO J=1,4
             N= IXC(J+1,I)
             NBCS = NBCS + ITAG(N)
            END DO
            IF (NBCS >0) THEN
             NE_BC4 =NE_BC4 + 1
             IE_BC4(NE_BC4) = I
            END IF
           END DO
          END IF
       END DO !NG = 
C-------NBC = 0          
      ELSEIF (NBC_B == 0) THEN
       N3=0
       N4=0
       MAS =ZERO
       XC = ZERO
       YC = ZERO
       ZC = ZERO
       DO NG = 1, NGROUP
          IF(IPARG(8,NG)==1) CYCLE
          ITY   =IPARG(5,NG)
          IF (ITY /= 3 .AND. ITY /= 7) CYCLE
          MLW   =IPARG(1,NG)
C MLW= 0 ----> void; MLW = 13 ----> rigid material
          IF (MLW == 0 .OR. MLW == 13) CYCLE
           NEL   =IPARG(2,NG)
           JFT=1
           JLT=MIN(NVSIZ,NEL)
           NF1 = IPARG(3,NG)+1
           IF (ITY==7) THEN
             N3 =N3 +1
           CALL CGSHELL3(ELBUF_TAB(NG),JFT,JLT ,PM   ,IXTG(1,NF1),
     +                  X   ,MAS,XC ,YC ,ZC )
          ELSEIF (ITY==3) THEN
             N4 =N4 +1
           CALL CGSHELL4(ELBUF_TAB(NG),JFT,JLT ,PM   ,IXC(1,NF1),
     +                  X   ,MAS,XC ,YC ,ZC )
          END IF
       END DO !IG = 1, NGROUC
C
       IF (N3==0.AND.N4==0) THEN
C-------warning out-- 
       ELSE
        IF (NSPMD>1) THEN
         MAST = MAS
         CALL SPMD_SUM_S(MAST)
         CALL SPMD_SUM_S(XC)
         CALL SPMD_SUM_S(YC)
         CALL SPMD_SUM_S(ZC)
         MAS = MAST
        END IF
        XC = XC/MAS
        YC = YC/MAS
        ZC = ZC/MAS
C
        XMIN=EP30        
        YMIN=EP30        
        ZMIN=EP30        
        DMIN=EP30        
       DO NG = 1, NGROUP
          IF(IPARG(8,NG)==1) CYCLE
          ITY   =IPARG(5,NG)
          IF (ITY /= 3 .AND. ITY /= 7) CYCLE
          MLW   =IPARG(1,NG)
C 
          IF (MLW == 0 .OR. MLW == 13) CYCLE
           NEL   =IPARG(2,NG)
           JFT   =IPARG(3,NG) + 1
           JLT   = IPARG(3,NG) + NEL
          IF (ITY==7) THEN
           CALL SPB_REFSH3ID(JFT,JLT,NEL,IXTG,X,XC,YC,ZC,
     +                       E_REF,XMIN,YMIN,ZMIN,DMIN)
          ELSEIF (ITY==3) THEN
           CALL SPB_REFSH4ID(JFT,JLT,NEL,IXC,X,XC,YC,ZC,
     +                       E_REF,XMIN,YMIN,ZMIN,DMIN)
          END IF
        END DO !IG = 1, NGROUC
C-------to get unique ref-element        
        IF (NSPMD>1) THEN
         XMING = XMIN
         CALL SPMD_MIN_S(XMING)
         IF (XMING<XMIN) E_REF(1)=0
         YMING = YMIN
         CALL SPMD_MIN_S(YMING)
         IF (YMING<YMIN) E_REF(2)=0
         ZMING = ZMIN
         CALL SPMD_MIN_S(ZMING)
         IF (ZMING<ZMIN) E_REF(3)=0
         DMING = DMIN
         CALL SPMD_MIN_S(DMING)
         IF (DMING<DMIN) E_REF(4)=0
        END IF
       END IF   !((N3==0.AND.N4==0).OR.N3>1 .OR. N4>1)     
      END IF !(NBC>0) THEN
      IF (NBC >0) DEALLOCATE(ITAG)
C      
      RETURN
      END
Chd|====================================================================
Chd|  SPB_REFSH4ID                  source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        SPBRM_PRE                     source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|====================================================================
      SUBROUTINE SPB_REFSH4ID(JFT,JLT,NEL,IXC,X,XC,YC,ZC,IE,
     +                        XMIN0,YMIN0,ZMIN0,DMIN)
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER IXC(NIXC,*),JFT, JLT,IE(4),NEL
C     REAL
      my_real
     .       X(3,*),XC,YC,ZC,DMIN,XMIN0,YMIN0,ZMIN0
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER  N,I,II,ND,INDEX(NEL),IEL,J
      my_real
     .       XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,D,XM,YM,ZM,DMINL,
     .       XMINL,YMINL,ZMINL
C---get reference ele (shell for the moment) for rigid motion compute
C---- E_id : nearest the gravity center----
       ND =0
       DO I = JFT,JLT
        XMIN=EP30
        XMAX=-EP30
        YMIN=EP30
        YMAX=-EP30
        ZMIN=EP30
        ZMAX=-EP30 
         DO J=1,4
          N= IXC(J+1,I)
          XMIN=MIN(XMIN,X(1,N))
          XMAX=MAX(XMAX,X(1,N))
          YMIN=MIN(YMIN,X(2,N))
          YMAX=MAX(YMAX,X(2,N))
          ZMIN=MIN(ZMIN,X(3,N))
          ZMAX=MAX(ZMAX,X(3,N))
         END DO
        IF((XC < XMIN.OR.XC > XMAX).AND.(YC < YMIN.OR.YC > YMAX)
     +     .AND.(ZC < ZMIN.OR.ZC > ZMAX)) CYCLE
        ND = ND +1
        INDEX(ND) = I
       END DO
       IF (ND ==0) THEN
        IEL =0
       ELSE
        DO II = 1,ND
         I = INDEX(II)
         XM = ZERO
         YM = ZERO
         ZM = ZERO
         DO J=1,4
          N= IXC(J+1,I)
          XM=XM+X(1,N)
          YM=YM+X(2,N)
          ZM=ZM+X(3,N)
         END DO
         XM = FOURTH*XM- XC
         YM = FOURTH*YM- YC
         ZM = FOURTH*ZM- ZC
          XMINL=ABS(XM)
          YMINL=ABS(YM)
          ZMINL=ABS(ZM)
C-------- Z direction is removed 
          IF (XMINL<XMIN0) THEN
           IE(1) = I
           XMIN0 = XMINL
          END IF
          IF (YMINL<YMIN0) THEN
           IE(2) = I
           YMIN0 = YMINL
          END IF
c          IF (ZMINL<ZMIN0) THEN
c           IE(3) = I
c           ZMIN0 = ZMINL
c          END IF
         D=XM*XM+YM*YM
c         D=XM*XM+YM*YM+ZM*ZM
         IF (D < DMIN) THEN
          DMIN = D
C---------first node-----          
          IE(4) = I
         END IF
        END DO
       ENDIF
c       IF (IEL>0 .AND.DMINL<DMIN) THEN
c        IE(1:4) = IXC(2:5,IEL)
c        DMIN= DMINL
c       END IF
C       
      RETURN
      END
Chd|====================================================================
Chd|  SPB_REFSH3ID                  source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        SPBRM_PRE                     source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|====================================================================
      SUBROUTINE SPB_REFSH3ID(JFT,JLT,NEL,IXTG,X,XC,YC,ZC,IE,
     +                        XMIN0,YMIN0,ZMIN0,DMIN)
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER IXTG(NIXTG,*),JFT, JLT,IE(4),NEL
C     REAL
      my_real
     .       X(3,*),XC,YC,ZC,XMIN0,YMIN0,ZMIN0,DMIN
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER  N,I,II,ND,INDEX(NEL),IEL,J
      my_real
     .       XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,D,XM,YM,ZM,DMINL,
     .       XMINL,YMINL,ZMINL
C---get reference ele (shell for the moment) for rigid motion compute
C---- E_id : nearest the gravity center----
       ND =0
       DO I = JFT,JLT
        XMIN=EP30
        XMAX=-EP30
        YMIN=EP30
        YMAX=-EP30
        ZMIN=EP30
        ZMAX=-EP30 
         DO J=1,3
          N= IXTG(J+1,I)
          XMIN=MIN(XMIN,X(1,N))
          XMAX=MAX(XMAX,X(1,N))
          YMIN=MIN(YMIN,X(2,N))
          YMAX=MAX(YMAX,X(2,N))
          ZMIN=MIN(ZMIN,X(3,N))
          ZMAX=MAX(ZMAX,X(3,N))
         END DO
        IF((XC < XMIN.OR.XC > XMAX).AND.(YC < YMIN.OR.YC > YMAX)
     +     .AND.(ZC < ZMIN.OR.ZC > ZMAX)) CYCLE
        ND = ND +1
        INDEX(ND) = I
       END DO
       IF (ND ==0) THEN
        IEL =0
       ELSE
        DO II = 1,ND
         I = INDEX(II)
         XM = ZERO
         YM = ZERO
         ZM = ZERO
         DO J=1,3
          N= IXTG(J+1,I)
          XM=XM+X(1,N)
          YM=YM+X(2,N)
          ZM=ZM+X(3,N)
         END DO
         XM = THIRD*XM - XC
         YM = THIRD*YM - YC
         ZM = THIRD*ZM - ZC
          XMINL=ABS(XM)
          YMINL=ABS(YM)
          ZMINL=ABS(ZM)
          IF (XMINL<XMIN0) THEN
           IE(1) = I
           XMIN0 = XMINL
          END IF
          IF (YMINL<YMIN0) THEN
           IE(2) = I
           YMIN0 = YMINL
          END IF
          IF (ZMINL<ZMIN0) THEN
           IE(3) = I
           ZMIN0 = ZMINL
          END IF
         D=XM*XM+YM*YM
c         D=XM*XM+YM*YM+ZM*ZM
         IF (D < DMIN) THEN
          DMIN = D
C------------- tag tria w/ negative          
          IE(4) = -I
         END IF
        END DO
       ENDIF
c       IF (IEL>0 .AND.DMINL<DMIN) THEN
c        IE(1:3) = IXTG(2:4,IEL)
c        IE(4) = IE(3)
c        DMIN= DMINL
c       END IF
C       
      RETURN
      END
Chd|====================================================================
Chd|  SPB_RM_RIG                    source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_SOLV                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        GETIKCE                       source/implicit/imp_solv.F    
Chd|        SPB_IEREF3                    source/implicit/imp_solv.F    
Chd|        SPB_IEREF_BC                  source/implicit/imp_solv.F    
Chd|        SPB_REF_NDS                   source/implicit/imp_solv.F    
Chd|        SPB_RGMOD                     source/implicit/imp_solv.F    
Chd|        SPMD_E_REF                    source/mpi/implicit/imp_spmd.F
Chd|        SPMD_N_REF                    source/mpi/implicit/imp_spmd.F
Chd|        TRANSVG2L                     source/implicit/imp_solv.F    
Chd|        TRANSVL2G                     source/implicit/imp_solv.F    
Chd|        VELROT                        source/constraints/general/rbe2/rbe2v.F
Chd|        IMP_SPBRM                     share/modules/impbufdef_mod.F 
Chd|====================================================================
      SUBROUTINE SPB_RM_RIG(
     1    X         ,IXC       ,IXTG      ,NDOF      ,IDDL      ,
     2    IKC       ,D_IMP     ,DR_IMP    ,ICODT     ,ICODR     ,
     3    SKEW      ,ISKEW     ,itab      )
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE IMP_SPBRM
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "param_c.inc"
#include      "units_c.inc"
#include      "task_c.inc"
#include      "impl1_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER ICODT(*),ICODR(*),ISKEW(*)
      INTEGER
     .   IXC(NIXC,*), IXTG(NIXTG,*), NDOF(*),IDDL(*),IKC(*),itab(*)
C     REAL
      my_real
     .   X(3,*) ,D_IMP(3,*) ,DR_IMP(3,*)  ,SKEW(LSKEW,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER  N,I,J,ND,NN,IE,IEM,NKC,K,ILOC,ISK,IKCL(6)
      my_real
     .       DMIN,D,XC,YC,ZC,DTRA(3),DROT(3),DRS(3),LSM(3),
     .       X0,Y0,Z0,DTRAL(3),DROTL(3),LSML(3),DRS1(3),DROT1(3),DROTL1(3)
C------remove rigid motion of springback (increment)
C----- find reference element: IF BCS the one of smallest Disp w/ BCS (doing ech time)
C------------------------------else nearest the GC of blank (done only once)
C------should update X_REF,D_REF each cycle---
C------case input 3N---
        IF (IRIG_M>1) THEN
         CALL SPB_REF_NDS(
     1    X         ,D_IMP     ,NDOF      ,IDDL      ,IKC       ,
     2    ICODT     ,ICODR     ,ISKEW     ,SKEW      )
           IF (ILSKEW>0) THEN
C----get ISK(from E_REF)set [Q],transfert DTRA,DROT to local reset IKCE(6) put (j)=0 for fixing dir
             NN = ILSKEW
             ISK = ISKEW(NN)
C---------local IKC
             RLSKEW(1:9) = SKEW(1:9,ISK)        
             CALL GETIKCE(ICODT(NN),ICODR(NN),NDOF(NN),IKCE)
           END IF
         IF (NSPMD>1) CALL SPMD_N_REF()
        ELSE
          IF (NBC_B>0) THEN
           CALL SPB_IEREF_BC(
     1    X         ,IXC       ,IXTG      ,D_IMP    ,DMIN   ,
     2    NDOF      ,IDDL      ,IKC       )
            IF (ILSKEW>0) THEN
C----get ISK(from E_REF)set [Q],transfert DTRA,DROT to local reset IKCE(6) put (j)=0 for fixing dir
             NN = ILSKEW
             ISK = ISKEW(NN)
C---------local IKC
             RLSKEW(1:9) = SKEW(1:9,ISK)        
             CALL GETIKCE(ICODT(NN),ICODR(NN),NDOF(NN),IKCE)
            END IF
          ELSE
           CALL SPB_IEREF3(
     1    X         ,IXC       ,IXTG      ,NDOF      ,IDDL      ,
     2    IKC       ,D_IMP     ,DR_IMP    ,DMIN )
          END IF
C--------communication IKCE,X_REF,D_REF,RLSKEW,N_SEG, LSKEW_G   
          IF (NSPMD>1) CALL SPMD_E_REF(DMIN)
        END IF !(IRIG_M>1) THEN
C      
       IF (N_SEG==0) RETURN
C-----IKCE : only local BCS nodes are initialized-----       
       CALL SPB_RGMOD(N_SEG ,X_REF ,D_REF ,X   ,D_IMP  ,
     +                X0  ,Y0  ,Z0  ,DTRA,DROT )
       IF (NBC_B>0.OR.LSKEW_G>0) THEN
        DO J=1,3
         IF (IKCE(J)==1) DTRA(J)= ZERO
        ENDDO
c        IF (IRODDL/=0) THEN
          DO J=1,3
            IF (IKCE(J+3)==1) DROT(J)=ZERO
          ENDDO
c        END IF
       END IF
      IF (LSKEW_G>0) THEN
        CALL TRANSVG2L(RLSKEW,DTRA,DTRAL)
        CALL TRANSVG2L(RLSKEW,DROT,DROTL)
        DO J=1,3
         IF (IKCE(J)==1) DTRAL(J)= ZERO
         IF (IKCE(J+3)==1) DROTL(J)=ZERO
        ENDDO
        IF (IRODDL/=0) CALL TRANSVL2G(RLSKEW,DROTL,DROT) 
       DO I =1,NUMNOD
        NKC=0
        DO J=1,MIN(3,NDOF(I))
         ND = IDDL(I)+J
         IF (IKC(ND)/=0) NKC = NKC + 1
        ENDDO
        DROT1(1:3) = DROT(1:3)
C--------exclude the node w/all translational fixed      
        IF (NKC<3.AND.NDOF(I)>0) THEN
          LSM(1)=X(1,I)-X0
          LSM(2)=X(2,I)-Y0
          LSM(3)=X(3,I)-Z0             
C----transfert LSM to local     
c         CALL TRANSVG2L(RLSKEW,LSM,LSML)
          CALL VELROT(DROTL,LSML,DRS)
C------otherwise DL(1:3)= DRS+ DTRAL if fixing put DL(j)=0       
          DRS(1:3) = DRS(1:3) + DTRAL(1:3)
          IF (NKC>0) THEN
C----------suppose the same ISK w/ reference one
           CALL GETIKCE(ICODT(I),ICODR(I),NDOF(I),IKCL)
           DO J=1,3
            DROTL1(J) = DROTL(J)
            IF (IKCL(J)==1) DRS(J)= ZERO
            IF (IKCL(J+3)==1) DROTL1(J)= ZERO
           ENDDO
           CALL TRANSVL2G(RLSKEW,DROTL1,DROT1) 
          END IF !(NKC>0) THEN
          CALL TRANSVL2G(RLSKEW,DRS,DRS1) 
C----transfert DL DROT,to global     
          DO K=1,3
           D_IMP(K,I)=D_IMP(K,I)- DRS1(K)
          ENDDO
          IF (IRODDL/=0) THEN
           DO K=1,3
            DR_IMP(K,I)=DR_IMP(K,I)- DROT1(K)
           ENDDO
          END IF
        END IF
       ENDDO
      ELSE
       DO I =1,NUMNOD
        NKC=0
        DO J=1,MIN(3,NDOF(I))
         ND = IDDL(I)+J
         IF (IKC(ND)/=0) NKC = NKC + 1
        ENDDO
C--------exclude the node w/all translational fixed      
        IF (NKC<3.AND.NDOF(I)>0) THEN
          LSM(1)=X(1,I)-X0
          LSM(2)=X(2,I)-Y0
          LSM(3)=X(3,I)-Z0             
          CALL VELROT(DROT,LSM,DRS)
          DO K=1,3
           ND = IDDL(I)+K
           IF (IKC(ND)==0)D_IMP(K,I)=D_IMP(K,I)- DRS(K)- DTRA(K)
          ENDDO
          IF (IRODDL/=0) THEN
           DO K=1,3
            ND = IDDL(I)+K+3
            IF (IKC(ND)==0) DR_IMP(K,I)=DR_IMP(K,I)- DROT(K)
           ENDDO
          END IF
        END IF
       ENDDO
      END IF 
       IF (ITTOFF>0 .AND.NCYCLE==1) THEN
        write(iout,*)
        write(iout,*)'Segment served as Reference are the following nodes:'
		if (IRIG_M>1) THEN
          if (E_REF(1)>0) write(iout,*) 'NODE_ref 1 :',itab(E_REF(1))
          if (E_REF(2)>0) write(iout,*) 'NODE_ref 2 :',itab(E_REF(2))
          if (E_REF(3)>0) write(iout,*) 'NODE_ref 3 :',itab(E_REF(3))
		else
          if (E_REF(1)>0.AND.E_REF(2)>0.AND.E_REF(3)>0) then
          write(iout,*) (itab(E_REF(i)),i=1,N_SEG)
          else
          write(iout,*) (E_REF(i),i=1,N_SEG)
          end if
		end if
        write(iout,*)'Reference point at this moment:'
        write(iout,*)X0  ,Y0  ,Z0
        write(iout,*)'DTRA,DROT,N_SEG,ncycle=',N_SEG,ncycle
        write(iout,*)DTRA(1),DTRA(2),DTRA(3)
        write(iout,*)DROT(1),DROT(2),DROT(3)
        write(iout,*)'ILSKEW,LSKEW_G,ISPMD=',ILSKEW,LSKEW_G,ISPMD
        write(iout,*)RLSKEW(1),RLSKEW(2),RLSKEW(3)
        write(iout,*)
       END IF
c       IF (ITTOFF>0.AND.NCYCLE>1) THEN
c        write(iout,*)
c        write(iout,*)'DTRA,DROT,N_SEG,ILOC,ncycle=',N_SEG,ILOC,ncycle
c        write(iout,*)DTRA(1),DTRA(2),DTRA(3)
c        write(iout,*)DROT(1),DROT(2),DROT(3)
c        write(iout,*)'LSKEW_G,ISPMD=',LSKEW_G,ISPMD
c        write(iout,*)RLSKEW(1),RLSKEW(2),RLSKEW(3)
c        write(iout,*)
c       END IF
c      write(iout,*)'E_REF(i)=',(itab(E_REF(i)),i=1,4)
c      IF (ISPMD==0) THEN
c      write(iout,*)'X0,DTRA,DROT,N_SEG,ncycle=',N_SEG,ncycle
c      write(iout,*)X0  ,Y0  ,Z0
c      write(iout,*)DTRA(1),DTRA(2),DTRA(3)
c      write(iout,*)DROT(1),DROT(2),DROT(3)
c      END IF
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  SPB_IEREF_BC                  source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        SPB_RM_RIG                    source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        SPMD_MIN_S                    source/mpi/implicit/imp_spmd.F
Chd|        IMP_SPBRM                     share/modules/impbufdef_mod.F 
Chd|====================================================================
      SUBROUTINE SPB_IEREF_BC(
     1    X         ,IXC       ,IXTG      ,D_IMP     ,DMIN    ,
     2    NDOF      ,IDDL      ,IKC       )
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE IMP_SPBRM
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER
     .   NDOF(*),IDDL(*),IKC(*),IXC(NIXC,*), IXTG(NIXTG,*)
C     REAL
      my_real
     .   DMIN,X(3,*) ,D_IMP(3,*)   
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER  N,I,J,ND,NN,IE,IEM,K
      my_real
     .       D(3),DD,DMINT
C------remove rigid motion of springback (incremental)
C----- find reference element: IF BCS the smallest Disp(at element center)) w/BCS C-------
C------doing  once: NCYCLE=1
        DMIN=EP30
      IF (NCYCLE==1 )THEN
        ILSKEW = 0
        LSKEW_G = 0
        IKCE(1:6) = 0
        E_REF(1:4) = 0
        DO I = 1, NE_BC4       
         IE =IE_BC4(I)
         DO K = 1,3
          D(K) = ZERO
          DO J= 1,4
           N = IXC(J+1,IE)
           D(K) = D(K) + D_IMP(K,N)
          END DO
         END DO
         DD = MIN(ABS(D(1)),ABS(D(2)),ABS(D(3)))
         IF (DD < DMIN) THEN
          DMIN = DD
          E_REF(1:4) = IXC(2:5,IE)
         END IF
        END DO
C        
        DO I = 1, NE_BC3       
         IE =IE_BC3(I)
         DO K = 1,3
          D(K) = ZERO
          DO J= 1,3
           N = IXTG(J+1,IE)
           D(K) = D(K) + D_IMP(K,N)
          END DO
         END DO
         DD = MIN(ABS(D(1)),ABS(D(2)),ABS(D(3)))
         IF (DD < DMIN) THEN
          DMIN = DD
          E_REF(1:3) = IXTG(2:4,IE)
          E_REF(4) = E_REF(3)
         END IF
        END DO 
C-----not to use allow BCS (global only IKC=1) dof direction 
C----- add BCS w/ SKEW (ILSKEW=1 w/ ref); Ud (IKC=2,9) could also be added--
        DO J = 1, 4
         N = E_REF(J)
         IF (N==0) CYCLE
         DO K= 1,NDOF(N)
          ND = IDDL(N)+K
          IF (IKC(ND)>0.AND.IKCE(K)==0) IKCE(K) = 1
         END DO
        END DO 
C--------to limit change during the iteration and dependant of np        
        IF (NSPMD>1) THEN
         DMINT = DMIN
         CALL SPMD_MIN_S(DMINT)
C------not in this domain-----        
         IF (DMINT<DMIN) THEN
          E_REF(1:4) = 0
         END IF
        END IF
       IF ((E_REF(1)+E_REF(2)+E_REF(3)+E_REF(4))==0) THEN
        N_SEG = 0
       ELSEIF(E_REF(4) == E_REF(3)) THEN
        N_SEG = 3
       ELSE
        N_SEG = 4
       END IF
       IF (N_SEG>0) THEN
        DO J = 1, 4
         N = E_REF(J)
         IF (N==0) CYCLE
         DO K= 1,NDOF(N)
          ND = IDDL(N)+K
          IF (IKC(ND)==8) ILSKEW = N
         END DO
        END DO 
        IF (ILSKEW >0) LSKEW_G=1
       END IF
C-------Ncycle>1       
      ELSEIF ((E_REF(1)+E_REF(2)+E_REF(3)+E_REF(4)) >0) THEN
        DO K = 1, 3
         D(K) = ZERO
         DO J= 1,3
           N = E_REF(J)
           D(K) = D(K) + D_IMP(K,N)
         END DO
         IF (E_REF(4) /= E_REF(3)) THEN
           N = E_REF(4)
           D(K) = D(K) + D_IMP(K,N)
         END IF
        END DO
        DMIN = MIN(ABS(D(1)),ABS(D(2)),ABS(D(3)))
      END IF !(NCYCLE==1 )THEN
       X_REF(1:3,1:4) = ZERO
       D_REF(1:3,1:4) = ZERO
       IF (N_SEG > 0) THEN
         DO J= 1,4
          N = E_REF(J)
          X_REF(1:3,J)= X(1:3,N)
          D_REF(1:3,J)= D_IMP(1:3,N)
         END DO
       END IF 
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  SPB_RGMOD                     source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        SPB_RM_RIG                    source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|====================================================================
      SUBROUTINE SPB_RGMOD(N_SEG,X_REF ,D_REF ,X  ,D  ,
     1                     X0  ,Y0  ,Z0  ,DTRA  ,DROT  )
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER N_SEG
C     REAL
      my_real
     .   X_REF(3,4),D_REF(3,4),X(3,*),D(3,*),DTRA(3),DROT(3),
     .   X0  ,Y0  ,Z0  
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER  I, J, II, L, JJ,NJ,K,NIR
C     REAL
      my_real
     .   XX,YY,ZZ,XXX,YYY,ZZZ,XY,YZ,ZX,XY2,YZ2,ZX2,
     .   B1,B2,B3,C1,C2,C3,FACM,RJ(3,3,4),
     .   X22,Y22,Z22,DET,XM(4),YM(4),ZM(4)
      my_real
     .   XS,YS,ZS
C------------------------------------
C     MATRICE DE JACOBIEN [C]
C------------------------------------
       NIR=N_SEG
       DO J=1,NIR
C        NJ=IRECT(J)
        XM(J)=X_REF(1,J)
        YM(J)=X_REF(2,J)
        ZM(J)=X_REF(3,J)
       ENDDO 
       IF(NIR==3) THEN
        XM(4)=ZERO
        YM(4)=ZERO
        ZM(4)=ZERO
       ENDIF
       FACM = ONE / NIR
C----------------------------------------------------
C       VITESSE DE ROTATION MOYENNE DU SEGMENT MAIN
C----------------------------------------------------
        X0=FACM*(XM(1)+XM(2)+XM(3)+XM(4))
        Y0=FACM*(YM(1)+YM(2)+YM(3)+YM(4))
        Z0=FACM*(ZM(1)+ZM(2)+ZM(3)+ZM(4))       
        DO J=1,NIR
         XM(J)=XM(J)-X0
         YM(J)=YM(J)-Y0
         ZM(J)=ZM(J)-Z0
        ENDDO 
C-------
        XX=0 
        YY=0 
        ZZ=0 
        XY=0 
        YZ=0 
        ZX=0
        DO J=1,NIR
         XX=XX+ XM(J)*XM(J)
         YY=YY+ YM(J)*YM(J)
         ZZ=ZZ+ ZM(J)*ZM(J)
         XY=XY+ XM(J)*YM(J)
         YZ=YZ+ YM(J)*ZM(J)
         ZX=ZX+ ZM(J)*XM(J)
        ENDDO 
        ZZZ=XX+YY
        XXX=YY+ZZ
        YYY=ZZ+XX 
        XY2=XY*XY
        YZ2=YZ*YZ
        ZX2=ZX*ZX
        DET= XXX*YYY*ZZZ -XXX*YZ2 -YYY*ZX2 -ZZZ*XY2 -TWO*XY*YZ*ZX
        DET=ONE/DET
        B1=(ZZZ*YYY-YZ2)*DET
        B2=(XXX*ZZZ-ZX2)*DET
        B3=(YYY*XXX-XY2)*DET
        C3=(ZZZ*XY+YZ*ZX)*DET
        C1=(XXX*YZ+ZX*XY)*DET
        C2=(YYY*ZX+XY*YZ)*DET
        DO J=1,NIR
         X22 = C1*XM(J)
         Y22 = C2*YM(J)
         Z22 = C3*ZM(J)
C-------RJ=(R^tR)^-1Rj^t-(j=1,ndir)---
         RJ(1,1,J)=Z22-Y22
         RJ(2,1,J)=B2*ZM(J)-C1*YM(J)
         RJ(3,1,J)=C1*ZM(J)-B3*YM(J)
         RJ(1,2,J)=-B1*ZM(J)+C2*XM(J)
         RJ(2,2,J)=-Z22+X22
         RJ(3,2,J)=-C2*ZM(J)+B3*XM(J)
         RJ(1,3,J)=B1*YM(J)-C3*XM(J)
         RJ(2,3,J)=C3*YM(J)-B2*XM(J)
         RJ(3,3,J)=Y22-X22
        ENDDO
C        
       DO I=1,3
        DTRA(I)= ZERO
        DROT(I) = ZERO
        DO J=1,NIR
C         NJ=IRECT(J)
         DROT(I)=DROT(I)+RJ(I,1,J)*D_REF(1,J)+
     .           RJ(I,2,J)*D_REF(2,J)+RJ(I,3,J)*D_REF(3,J)
         DTRA(I)=DTRA(I)+FACM*D_REF(I,J)
        END DO
       END DO
C
      RETURN
      END
Chd|====================================================================
Chd|  SPB_IEREF3                    source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        SPB_RM_RIG                    source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        SPMD_MIN_S                    source/mpi/implicit/imp_spmd.F
Chd|        IMP_SPBRM                     share/modules/impbufdef_mod.F 
Chd|====================================================================
      SUBROUTINE SPB_IEREF3(
     1    X         ,IXC       ,IXTG      ,NDOF      ,IDDL      ,
     2    IKC       ,D_IMP     ,DR_IMP    ,DMIN )
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE IMP_SPBRM
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER
     .   IXC(NIXC,*), IXTG(NIXTG,*), NDOF(*),IDDL(*),IKC(*)
C     REAL
      my_real
     .   DMIN,X(3,*) ,D_IMP(3,*) ,DR_IMP(3,*)  
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER  N,I,J,ND,NN,IE,IEM,K,NSAVE(4)
      my_real
     .       D(3),DD,DR(3),DDR,DMINT
C----- find reference element: around element center))  
C--------NSAVE(1) : XMIN, 2 : YMIN, 3 : ZMIN, 4 : DMIN 
      DMIN=EP30
      IF (NCYCLE==1 )THEN
        NSAVE(1:4) = E_REF(1:4) 
        E_REF(1:4) = 0
          DO I = 1,4       
           IE =IABS(NSAVE(I))
           IF (IE==0) CYCLE
           DO K = 1,3
            D(K) = ZERO
            DR(K) = ZERO
            IF (NSAVE(4)<0) THEN
              DO J= 1,3
               N = IXTG(J+1,IE)
               D(K) = D(K) + D_IMP(K,N)
               DR(K) = DR(K) + DR_IMP(K,N)
              END DO
            ELSE
              DO J= 1,4
               N = IXC(J+1,IE)
               D(K) = D(K) + D_IMP(K,N)
               DR(K) = DR(K) + DR_IMP(K,N)
              END DO
            END IF
           END DO
           DD = MIN(ABS(D(1)),ABS(D(2)),ABS(D(3)))
           DDR = MAX(ABS(DR(1)),ABS(DR(2)),ABS(DR(3)))
C   -------min(max(DR(j))) (1:4)------         
           IF (DDR < DMIN) THEN
            DMIN = DDR
            IF (NSAVE(4)<0) THEN
             E_REF(1:3) = IXTG(2:4,IE)
             E_REF(4) = E_REF(3)
            ELSE
             E_REF(1:4) = IXC(2:5,IE)
            END IF
           END IF
          END DO
C        
       IF (NSPMD>1) THEN
        DMINT = DMIN
        CALL SPMD_MIN_S(DMINT)
C------not in this domain-----        
        IF (DMINT<DMIN) THEN
         E_REF(1:4) = 0
        END IF
       END IF
       IF ((E_REF(1)+E_REF(2)+E_REF(3)+E_REF(4))==0) THEN
        N_SEG = 0
       ELSEIF(E_REF(4) == E_REF(3)) THEN
        N_SEG = 3
       ELSE
        N_SEG = 4
       END IF
C---- Ncycle>1       
      ELSE
       IF ((E_REF(1)+E_REF(2)+E_REF(3)+E_REF(4))==0) N_SEG = 0
       IF (N_SEG>0) THEN
        DO K = 1, 3
         DR(K) = ZERO
         DO J= 1,3
           N = E_REF(J)
           DR(K) = DR(K) + DR_IMP(K,N)
         END DO
         IF (E_REF(4) /= E_REF(3)) THEN
           N = E_REF(4)
           DR(K) = DR(K) + DR_IMP(K,N)
         END IF
        END DO
        DMIN = MAX(ABS(DR(1)),ABS(DR(2)),ABS(DR(3)))
       END IF !(N_SEG>0) THEN
      END IF !(NCYCLE==1 )THEN
       X_REF(1:3,1:4) = ZERO
       D_REF(1:3,1:4) = ZERO
       IF (N_SEG > 0) THEN
         DO J= 1,4
          N = E_REF(J)
          X_REF(1:3,J)= X(1:3,N)
          D_REF(1:3,J)= D_IMP(1:3,N)
         END DO
       END IF 
C------------------------------------------
      RETURN
      END
Chd|====================================================================
Chd|  IMP_INTBUF_INI                source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        DIM_INT7                      source/implicit/ind_glob_k.F  
Chd|-- calls ---------------
Chd|        IMP_INTBUFDEF                 share/modules/imp_mod_def.F   
Chd|====================================================================
      SUBROUTINE IMP_INTBUF_INI(IMP_INTBUF_TAB,NIMP)  
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE IMP_INTBUFDEF             
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      TYPE(IMP_INTBUF_STRUCT_) IMP_INTBUF_TAB(*)
      INTEGER NIMP(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,N,NI,SIZ,I_CONT
C=======================================================================

      DO NI= 1, NINTER
        I_CONT = NIMP(NI)
        IMP_INTBUF_TAB(NI)%S_I_STOK        = 1 
        IMP_INTBUF_TAB(NI)%S_CAND_N       = 0   
        IMP_INTBUF_TAB(NI)%S_CAND_E       = 0   
        IMP_INTBUF_TAB(NI)%S_INDSUBT      = 0   
        IMP_INTBUF_TAB(NI)%S_HJ         = 0   
        IMP_INTBUF_TAB(NI)%S_NJ         = 0   
        IMP_INTBUF_TAB(NI)%S_STIF         = 0   
        ALLOCATE(IMP_INTBUF_TAB(NI)%I_STOK(IMP_INTBUF_TAB(NI)%S_I_STOK)) 
        IMP_INTBUF_TAB(NI)%I_STOK(1:IMP_INTBUF_TAB(NI)%S_I_STOK) = 0
       IF (I_CONT > 0) THEN
        IMP_INTBUF_TAB(NI)%S_CAND_N       = I_CONT   
        IMP_INTBUF_TAB(NI)%S_CAND_E       = I_CONT   
        IMP_INTBUF_TAB(NI)%S_INDSUBT       = I_CONT   
        IMP_INTBUF_TAB(NI)%S_HJ   = 4*I_CONT
        IMP_INTBUF_TAB(NI)%S_NJ   = 3*I_CONT
        IMP_INTBUF_TAB(NI)%S_STIF = I_CONT
C------Allocate, ini to zero        
        ALLOCATE(IMP_INTBUF_TAB(NI)%CAND_N(IMP_INTBUF_TAB(NI)%S_CAND_N)) 
        IMP_INTBUF_TAB(NI)%CAND_N(1:IMP_INTBUF_TAB(NI)%S_CAND_N) = 0
        ALLOCATE(IMP_INTBUF_TAB(NI)%CAND_E(IMP_INTBUF_TAB(NI)%S_CAND_E)) 
        IMP_INTBUF_TAB(NI)%CAND_E(1:IMP_INTBUF_TAB(NI)%S_CAND_E) = 0
        ALLOCATE(IMP_INTBUF_TAB(NI)%INDSUBT(IMP_INTBUF_TAB(NI)%S_INDSUBT)) 
        IMP_INTBUF_TAB(NI)%INDSUBT(1:IMP_INTBUF_TAB(NI)%S_INDSUBT) = 0
C        
        ALLOCATE(IMP_INTBUF_TAB(NI)%HJ(IMP_INTBUF_TAB(NI)%S_HJ)) 
        IMP_INTBUF_TAB(NI)%HJ(1:IMP_INTBUF_TAB(NI)%S_HJ) = ZERO
        ALLOCATE(IMP_INTBUF_TAB(NI)%NJ(IMP_INTBUF_TAB(NI)%S_NJ)) 
        IMP_INTBUF_TAB(NI)%NJ(1:IMP_INTBUF_TAB(NI)%S_NJ) = ZERO
        ALLOCATE(IMP_INTBUF_TAB(NI)%STIF(IMP_INTBUF_TAB(NI)%S_STIF)) 
        IMP_INTBUF_TAB(NI)%STIF(1:IMP_INTBUF_TAB(NI)%S_STIF) = ZERO
       END IF
         
      ENDDO !NI=1,NINTER

C-----
      RETURN

      END SUBROUTINE IMP_INTBUF_INI
Chd|====================================================================
Chd|  IMP_ERRMUMPS                  source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        SPMD_MUMPS_EXEC               source/mpi/implicit/imp_spmd.F
Chd|-- calls ---------------
Chd|        IMP_STOP                      source/implicit/imp_solv.F    
Chd|====================================================================
      SUBROUTINE IMP_ERRMUMPS(IERR)
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include "units_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER  IERR,ISTOP
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
       WRITE(ISTDO,1000)IERR
       WRITE(IOUT,1000)IERR
        SELECT CASE (-IERR)
          CASE(7,8,9,11,13,14,15,17)
            WRITE(ISTDO,1030)
            WRITE(IOUT,1010)
          CASE(6,10)
            WRITE(ISTDO,2000)
            WRITE(IOUT,2010)
        END SELECT
      IF(IERR<0)THEN
        ISTOP=-4
        CALL IMP_STOP(ISTOP)
      END IF
C
      RETURN
 1000 FORMAT(/
     .       '    ** LINEAR SOLVER MUMPS ERROR CODE: ',I6/)
 1030 FORMAT(/
     .       '    ** ERROR MEMORY ISSUE            ' /)
 1010 FORMAT(/
     .       '    ** ERROR MEMORY ISSUE. POSSIBLE SOLUTIONS:' /,
     .       '    *RUN ON A COMPUTER WITH MORE MEMORY ;' /,
     .       '    *TRY LESS THREADS AND LESS PROCS PER COMPUTER NODE ;' /,
     .       '    *CLOSE OTHER APPLICATIONS ;           ' /)
 2000 FORMAT(/
     .       '    ** ERROR OF SINGULAR MATRIX ' /)
 2010 FORMAT(/
     .       '    ** ERROR OF SINGULAR MATRIX. POSSIBLE SOLUTIONS:' /,
     .       '    *CHECK IF THE MODEL IS WELL CONDITIONED ;' /,
     .       '    *TRYING QUASI-STATIC SOLUTION ; ' /)
      END



Chd|====================================================================
Chd|  PVP_K                         source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        IMP_CHKM                      source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        JACOBIEN                      source/implicit/imp_glob_k.F  
Chd|        MINV_K                        source/implicit/imp_solv.F    
Chd|        ECND_MOD                      share/modules/ecdn_mod.F      
Chd|====================================================================
      SUBROUTINE PVP_K(ND  ,IADK,JDIK,IDDL ,INLOC,
     .                 NDOF,ITAB,K_DIAG,K_LT ,LAMDA, NODE,MS  )
C----6---------------------------------------------------------------7---------8
      USE ECND_MOD
C----6---------------------------------------------------------------7---------8
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "units_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER ND,NODE
      INTEGER JDIK(*)  ,IADK(*),IDDL(*),INLOC(*),NDOF(*),ITAB(*)
C     REAL
      my_real
     .   K_DIAG(*) ,K_LT(*) ,LAMDA,MS(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,K,J,IK,ID,JD,L,N,NN,JJ,IDT
      my_real
     .   KE(ND,ND) ,EV(ND,ND),EW(ND),LA,TOL,MSD(ND),MSIJ,TOL1
C----6----------------------------------
        TOL=EM5
        TOL1=EM10
        KE(1:ND,1:ND)=ZERO
        NODE = 0
        LAMDA = ZERO
      IF (NS10E==0) THEN
C-----taking into account to M-1       
       DO N =1,NUMNOD
        I=INLOC(N)
        DO J=1,NDOF(I)
         IK = IDDL(I)+J
         MSD(IK)=MS(I)
C----free node         
         IF (MSD(IK)<EM20) MSD(IK)=ONE
        ENDDO
       ENDDO
        DO K=1,ND
         KE(K,K) = K_DIAG(K)/MSD(K)
         DO J = IADK(K),IADK(K+1)-1
          JD = JDIK(J)
          MSIJ=ONE/SQRT(MSD(K))/SQRT(MSD(JD))  
          KE(K,JD) = K_LT(J)*MSIJ
          KE(JD,K) = KE(K,JD)
         ENDDO
        ENDDO
      ELSE
C-------itet=2 (not dumped [M]), should not mix w/ other elements      
        DO K=1,ND
         KE(K,K) = K_DIAG(K)
         DO J = IADK(K),IADK(K+1)-1
          JD = JDIK(J)
          KE(K,JD) = K_LT(J)
          KE(JD,K) = KE(K,JD)
         ENDDO
        ENDDO
        CALL MINV_K(ND  ,ICNDS10,IDDL ,INLOC,NDOF,
     .              MS  ,TOL ,KE   )
      END IF !(NS10E==0) THEN
       CALL JACOBIEN(KE,ND,EW,EV,TOL1,LAMDA)
C---Node:N direction:J 
        ID = 0
        DO K=1,ND
         IF (EW(K)>=LAMDA) ID = K
         IF (ID > 0 ) CYCLE
        ENDDO
       DO N =1,NUMNOD
        I=INLOC(N)
        JJ = 0
        DO J=1,NDOF(I)
         IK = IDDL(I)+J
         IF (IK==ID) JJ= J
        ENDDO
        IF (JJ > 0) THEN
         NODE= N
         WRITE(IOUT,*)'1er EIGENVALUE(K/M) OF NODE+DIR:',LAMDA,ITAB(N),JJ
         CYCLE
        END IF
       ENDDO
C
      RETURN
      END
Chd|====================================================================
Chd|  MINV_K                        source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        PVP_K                         source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        JACOBIEN                      source/implicit/imp_glob_k.F  
Chd|====================================================================
      SUBROUTINE MINV_K(ND  ,ICNDS10,IDDL ,INLOC,NDOF,
     .                  MS  ,TOL ,KE   )
C----6---------------------------------------------------------------7---------8
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER ND
      INTEGER ICNDS10(3,*),IDDL(*),INLOC(*),NDOF(*)
C     REAL
      my_real
     .   KE(ND,ND) ,MS(*),TOL
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,K,J,IK,ID,JD,L,N,NN,N1,N2,II,JJ,JK
      my_real
     .   EV(ND,ND),EW(ND),
     .   LA,MSD(ND),MSIJ,LAMDA,ME(ND,ND),MSND,MSII
C----6----------------------------------
        LAMDA = ZERO
       ME(1:ND,1:ND) = ZERO
       DO I =1,NS10E
        NN  = IABS(ICNDS10(1,I))
        N1  = ICNDS10(2,I)
        N2  = ICNDS10(3,I)
        ID=INLOC(NN)
        MSND = MS(ID) 
        DO J=1,NDOF(ID)
         IK = IDDL(ID)+J
         ME(IK,IK)=ME(IK,IK)+MSND
        END DO
        II=INLOC(N1)
        MSII = THIRD*MS(II) + FOURTH*MSND
        DO J=1,NDOF(II)
         IK = IDDL(II)+J
         ME(IK,IK)=ME(IK,IK)+MSII
        END DO
        JJ=INLOC(N2)
        MSII = THIRD*MS(JJ) + FOURTH*MSND
        DO J=1,NDOF(JJ)
         IK = IDDL(JJ)+J
         ME(IK,IK)=ME(IK,IK)+MSII
        END DO
C--------- m12
        MSII = FOURTH*MSND
C--------suppose NDOF(II)= NDOF(JJ) = NDOF(ID)     
        DO J=1,NDOF(II)
         IK = IDDL(II)+J
         JK = IDDL(JJ)+J
         ME(IK,JK)=ME(IK,JK)+MSII
         ME(JK,IK)=ME(JK,IK)+MSII
        END DO
C--------- m13,m23
        MSII = -HALF*MSND
        DO J=1,NDOF(II)
         IK = IDDL(II)+J
         JK = IDDL(ID)+J
         ME(IK,JK)=ME(IK,JK)+MSII
         ME(JK,IK)=ME(JK,IK)+MSII
        END DO
        DO J=1,NDOF(JJ)
         IK = IDDL(JJ)+J
         JK = IDDL(ID)+J
         ME(IK,JK)=ME(IK,JK)+MSII
         ME(JK,IK)=ME(JK,IK)+MSII
        END DO        
       END DO !I =1,NS10E
       DO I =1,ND
       DO J =I,ND
         ME(J,I)=ME(I,J)
       END DO 
       END DO 
       CALL JACOBIEN(ME,ND,EW,EV,TOL,LAMDA)
C-------[EV]'-> [EV]*EW^-1/2       
       DO I =1,ND
c        print *,'M, ME(I,I),I=',ME(I,I),I
         EW(I)=ONE/SQRT(EW(I))
       END DO 
       DO I =1,ND
        DO J =1,ND
         EV(I,J)=EV(I,J)*EW(J)
        END DO 
       END DO 
C-------[K]-> [EV]^t*[K]*[EV]      
       ME(1:ND,1:ND) = ZERO
        DO I=1,ND 
        DO J=1,ND
         DO K = 1,ND        
          ME(I,J)=ME(I,J)+KE(I,K)*EV(K,J)
         ENDDO
        ENDDO
        ENDDO
       KE(1:ND,1:ND) = ZERO
        DO I=1,ND 
        DO J=1,ND
         DO K = 1,ND        
          KE(I,J)=KE(I,J)+EV(K,I)*ME(K,J)
         ENDDO
        ENDDO
        ENDDO
C
      RETURN
      END
Chd|====================================================================
Chd|  GETIKCE                       source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        SPB_REF_NDS                   source/implicit/imp_solv.F    
Chd|        SPB_RM_RIG                    source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|====================================================================
      SUBROUTINE GETIKCE(ICT ,ICR,K,IFIX )
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER ICT,ICR,IFIX(6),K
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER ND
C----------------BC-------------------------
        IFIX(1:6) = 0
        ND = 0
        IF (ICT > 0 .AND. K> 0) THEN
         IF (ICT == 4 .AND. K>2) THEN
          IFIX(ND +1) = 1
         ELSEIF (ICT == 2) THEN
          IFIX(ND +2) = 1
         ELSEIF (ICT == 1) THEN
          IFIX(ND +3) = 1
         ELSEIF (ICT == 3) THEN
          IFIX(ND +2) = 1
          IFIX(ND +3) = 1
         ELSEIF (ICT == 5) THEN
          IF (K>2) IFIX(ND +1) = 1
          IFIX(ND +3) = 1
         ELSEIF (ICT == 6) THEN
          IF (K>2) IFIX(ND +1) = 1
          IFIX(ND +2) = 1
         ELSEIF (ICT == 7) THEN
          IF (K>2) IFIX(ND +1) = 1
          IFIX(ND +2) = 1
          IFIX(ND +3) = 1
         ENDIF
        ENDIF
C        
        IF (ICR > 0 .AND. K==6) THEN
         IF (ICR == 1) THEN
          IFIX(ND +6) = 1
         ELSEIF (ICR == 2) THEN
          IFIX(ND +5) = 1
         ELSEIF (ICR == 3) THEN
          IFIX(ND +5) = 1
          IFIX(ND +6) = 1
         ELSEIF (ICR == 4) THEN
          IFIX(ND +4) = 1
         ELSEIF (ICR == 5) THEN
          IFIX(ND +4) = 1
          IFIX(ND +6) = 1
         ELSEIF (ICR == 6) THEN
          IFIX(ND +4) = 1
          IFIX(ND +5) = 1
         ELSEIF (ICR == 7) THEN
          IFIX(ND +4) = 1
          IFIX(ND +5) = 1
          IFIX(ND +6) = 1
         ENDIF
        ENDIF
C
      RETURN
      END
Chd|====================================================================
Chd|  TRANSVG2L                     source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        SPB_RM_RIG                    source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|====================================================================
      SUBROUTINE TRANSVG2L(SKEW  ,VG  ,VL  )
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      my_real
     .   SKEW(*),VG(*),VL(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER J
C----------------------------------------
       VL(1)=SKEW(1)*VG(1)+SKEW(2)*VG(2)+SKEW(3)*VG(3)
       VL(2)=SKEW(4)*VG(1)+SKEW(5)*VG(2)+SKEW(6)*VG(3)
       VL(3)=SKEW(7)*VG(1)+SKEW(8)*VG(2)+SKEW(9)*VG(3)
C
      RETURN
      END
Chd|====================================================================
Chd|  TRANSVL2G                     source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        SPB_RM_RIG                    source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|====================================================================
      SUBROUTINE TRANSVL2G(SKEW  ,VL  ,VG  )
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      my_real
     .   SKEW(*),VG(*),VL(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER J
C----------------------------------------
       VG(1)=SKEW(1)*VL(1)+SKEW(4)*VL(2)+SKEW(7)*VL(3)
       VG(2)=SKEW(2)*VL(1)+SKEW(5)*VL(2)+SKEW(8)*VL(3)
       VL(3)=SKEW(3)*VL(1)+SKEW(6)*VL(2)+SKEW(9)*VL(3)
C
      RETURN
      END
Chd|====================================================================
Chd|  SPB_REF_NDS                   source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        SPB_RM_RIG                    source/implicit/imp_solv.F    
Chd|-- calls ---------------
Chd|        GETIKCE                       source/implicit/imp_solv.F    
Chd|        IMP_SPBRM                     share/modules/impbufdef_mod.F 
Chd|====================================================================
      SUBROUTINE SPB_REF_NDS(
     1    X         ,D_IMP     ,NDOF      ,IDDL      ,IKC       ,
     2    ICODT     ,ICODR     ,ISKEW     ,SKEW      )
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE IMP_SPBRM
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER
     .   NDOF(*),IDDL(*),IKC(*),ICODT(*),ICODR(*),ISKEW(*)
C     REAL
      my_real
     .   X(3,*) ,D_IMP(3,*) ,SKEW(LSKEW,*)  
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER  N,I,J,ND,NN,IE,IEM,K,ISK
      my_real
     .       D(3),DD,DMINT
C------case input 3 ref_nodes
       X_REF(1:3,1:4) = ZERO
       D_REF(1:3,1:4) = ZERO
       N_SEG = 3
       DO J= 1,N_SEG
         N = E_REF(J)
         IF (N==0) CYCLE
         X_REF(1:3,J)= X(1:3,N)
         D_REF(1:3,J)= D_IMP(1:3,N)
       END DO
        IF (ILSKEW>0) THEN
C----get ISK(from E_REF)set [Q],transfert DTRA,DROT to local reset IKCE(6) put (j)=0 for fixing dir
          NN = ILSKEW
          ISK = ISKEW(NN)
C---------local IKC
          RLSKEW(1:9) = SKEW(1:9,ISK)        
          CALL GETIKCE(ICODT(NN),ICODR(NN),NDOF(NN),IKCE)
        END IF
C------------------------------------------
      RETURN
      END
C
Chd|====================================================================
Chd|  DEALLOC_IMPBUF                source/implicit/imp_solv.F    
Chd|-- called by -----------
Chd|        RESOL                         source/engine/resol.F         
Chd|-- calls ---------------
Chd|        IMPBUFDEF_MOD                 share/modules/impbufdef_mod.F 
Chd|====================================================================
      SUBROUTINE DEALLOC_IMPBUF(IMPBUF_TAB)
C-----------------------------------------------
      USE IMPBUFDEF_MOD
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      TYPE (IMPBUF_STRUCT_) IMPBUF_TAB
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
C
        IF (ALLOCATED(IMPBUF_TAB%IDDL)) DEALLOCATE(IMPBUF_TAB%IDDL)
        IF (ALLOCATED(IMPBUF_TAB%NDOF)) DEALLOCATE(IMPBUF_TAB%NDOF)
        IF (ALLOCATED(IMPBUF_TAB%INLOC)) DEALLOCATE(IMPBUF_TAB%INLOC)
        IF (ALLOCATED(IMPBUF_TAB%IRBYAC))DEALLOCATE(IMPBUF_TAB%IRBYAC)         
        IF (ALLOCATED(IMPBUF_TAB%NSC))   DEALLOCATE(IMPBUF_TAB%NSC)        
        IF (ALLOCATED(IMPBUF_TAB%IINT2)) DEALLOCATE(IMPBUF_TAB%IINT2)           
        IF (ALLOCATED(IMPBUF_TAB%NKUD))  DEALLOCATE(IMPBUF_TAB%NKUD)          
        IF (ALLOCATED(IMPBUF_TAB%IMONV)) DEALLOCATE(IMPBUF_TAB%IMONV)            
        IF (ALLOCATED(IMPBUF_TAB%IADK)) DEALLOCATE(IMPBUF_TAB%IADK)
        IF (ALLOCATED(IMPBUF_TAB%JDIK)) DEALLOCATE(IMPBUF_TAB%JDIK)
        IF (ALLOCATED(IMPBUF_TAB%IKINW)) DEALLOCATE(IMPBUF_TAB%IKINW)
        IF (ALLOCATED(IMPBUF_TAB%IKC)) DEALLOCATE(IMPBUF_TAB%IKC)
        IF (ALLOCATED(IMPBUF_TAB%IKUD)) DEALLOCATE(IMPBUF_TAB%IKUD)
        IF (ALLOCATED(IMPBUF_TAB%W_DDL)) DEALLOCATE(IMPBUF_TAB%W_DDL)
        IF (ALLOCATED(IMPBUF_TAB%IADM)) DEALLOCATE(IMPBUF_TAB%IADM)
        IF (ALLOCATED(IMPBUF_TAB%JDIM)) DEALLOCATE(IMPBUF_TAB%JDIM)
        IF (ALLOCATED(IMPBUF_TAB%CAND_N)) DEALLOCATE(IMPBUF_TAB%CAND_N)
        IF (ALLOCATED(IMPBUF_TAB%CAND_E)) DEALLOCATE(IMPBUF_TAB%CAND_E)
        IF (ALLOCATED(IMPBUF_TAB%INDSUBT)) DEALLOCATE(IMPBUF_TAB%INDSUBT)
        IF (ALLOCATED(IMPBUF_TAB%NDOFI)) DEALLOCATE(IMPBUF_TAB%NDOFI)
        IF (ALLOCATED(IMPBUF_TAB%IDDLI)) DEALLOCATE(IMPBUF_TAB%IDDLI)
        IF (ALLOCATED(IMPBUF_TAB%INBUF_C)) DEALLOCATE(IMPBUF_TAB%INBUF_C)
	    IF (ALLOCATED(IMPBUF_TAB%DIAG_K)) DEALLOCATE(IMPBUF_TAB%DIAG_K) 
	    IF (ALLOCATED(IMPBUF_TAB%LT_K))   DEALLOCATE(IMPBUF_TAB%LT_K)   
	    IF (ALLOCATED(IMPBUF_TAB%DIAG_M)) DEALLOCATE(IMPBUF_TAB%DIAG_M) 
	    IF (ALLOCATED(IMPBUF_TAB%LT_M))   DEALLOCATE(IMPBUF_TAB%LT_M)   
	    IF (ALLOCATED(IMPBUF_TAB%LB))     DEALLOCATE(IMPBUF_TAB%LB)     
	    IF (ALLOCATED(IMPBUF_TAB%LB0))    DEALLOCATE(IMPBUF_TAB%LB0)     
	    IF (ALLOCATED(IMPBUF_TAB%BKUD))   DEALLOCATE(IMPBUF_TAB%BKUD)   
	    IF (ALLOCATED(IMPBUF_TAB%D_IMP))  DEALLOCATE(IMPBUF_TAB%D_IMP)  
	    IF (ALLOCATED(IMPBUF_TAB%DR_IMP)) DEALLOCATE(IMPBUF_TAB%DR_IMP) 
        IF (ALLOCATED(IMPBUF_TAB%ELBUF_C)) DEALLOCATE(IMPBUF_TAB%ELBUF_C)
		IF (ALLOCATED(IMPBUF_TAB%BUFMAT_C))DEALLOCATE(IMPBUF_TAB%BUFMAT_C)
		IF (ALLOCATED(IMPBUF_TAB%X_C)) DEALLOCATE(IMPBUF_TAB%X_C)
		IF (ALLOCATED(IMPBUF_TAB%DD)) DEALLOCATE(IMPBUF_TAB%DD)
		IF (ALLOCATED(IMPBUF_TAB%DDR)) DEALLOCATE(IMPBUF_TAB%DDR)
		IF (ALLOCATED(IMPBUF_TAB%X_A))    DEALLOCATE(IMPBUF_TAB%X_A)   
		IF (ALLOCATED(IMPBUF_TAB%FEXT))   DEALLOCATE(IMPBUF_TAB%FEXT)  
		IF (ALLOCATED(IMPBUF_TAB%DG))     DEALLOCATE(IMPBUF_TAB%DG)    
		IF (ALLOCATED(IMPBUF_TAB%DGR))    DEALLOCATE(IMPBUF_TAB%DGR)   
		IF (ALLOCATED(IMPBUF_TAB%DG0))     DEALLOCATE(IMPBUF_TAB%DG0)    
		IF (ALLOCATED(IMPBUF_TAB%DGR0))    DEALLOCATE(IMPBUF_TAB%DGR0)   
		IF (ALLOCATED(IMPBUF_TAB%BUFIN_C)) DEALLOCATE(IMPBUF_TAB%BUFIN_C)
		IF (ALLOCATED(IMPBUF_TAB%AC)) DEALLOCATE(IMPBUF_TAB%AC)
		IF (ALLOCATED(IMPBUF_TAB%ACR)) DEALLOCATE(IMPBUF_TAB%ACR)
C
      RETURN
      END

